289 lines
9.4 KiB
Mathematica
289 lines
9.4 KiB
Mathematica
ACKQUTL4 ;HCIOFO/BH-NEW/EDIT Visit Template Utilities for QUASAR ; 04/01/99
|
|
;;3.0;QUASAR;**1,8,14**;Feb 11, 2000;Build 14
|
|
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
|
|
;
|
|
CHK(Y,ACKVD) ;
|
|
N ACKQQD
|
|
S ACKQQD=$P(^EC(725,Y,0),"^",3) I ACKQQD="" Q 1
|
|
I ACKVD<ACKQQD Q 1
|
|
Q 0
|
|
; Clears passed in field # of visit rec.
|
|
CLEAR(ACKVIEN,ACKZNUM) ;
|
|
N ACKARR
|
|
S ACKARR(509850.6,ACKVIEN_",",ACKZNUM)=""
|
|
D FILE^DIE("","ACKARR","")
|
|
Q
|
|
; Decides if patient is/was suffering from MST at the time of the visit
|
|
MST(ACKPCE,ACKVD,ACKPAT) ;
|
|
I '$$PATCH^XPDUTL("DG*5.3*308") Q 0
|
|
I ACKPCE'=1 Q 0
|
|
N ACKRET,ACKXKEEP
|
|
S ACKXKEEP=X
|
|
S ACKRET=$$GETSTAT^DGMSTAPI(ACKPAT,ACKVD)
|
|
S X=ACKXKEEP
|
|
I $P(ACKRET,"^",2)="Y" Q 1
|
|
Q 0
|
|
;
|
|
PROB(ACKPCE,ACKDIV) ; Decides if Update PCE Problem List prompt appaers
|
|
I 'ACKPCE Q 0
|
|
I '$$GET1^DIQ(509850.83,ACKDIV_",1",".09","I") Q 0
|
|
Q 1
|
|
;
|
|
SETUP ; Called from within the New/Edit visit template to set up parameters
|
|
;
|
|
D ENS^%ZISS
|
|
;
|
|
I ACKVISIT="EDIT" D
|
|
. K ACKAR
|
|
. S ACKAR(509850.6,ACKVIEN_",",.27)=""
|
|
. D FILE^DIE("K","ACKAR") K ACKAR
|
|
;
|
|
N ACKX,ACKD0
|
|
;
|
|
S (ICPTVDT,ICDVDT)=ACKVD
|
|
;
|
|
S ACKPCE=$$PCE(ACKDIV,ACKVD) ; Sets PCE indicator
|
|
;
|
|
S ACKEVENT=1
|
|
S ACKEVENT=$$EVENT^ACKQUTL5(ACKDIV,ACKVD) ; Use EC Codes or CPT
|
|
; Indicates whether local clinic #'s are in use
|
|
S ACKCLNO=$$GET1^DIQ(509850.83,ACKDIV_",1",".04","I")
|
|
;
|
|
; Indicates whether the bypass flag for Audiometrics is set
|
|
S ACKBA=$$GET1^DIQ(509850.83,ACKDIV_",1",".07","I")
|
|
;
|
|
; Indicates whether the visit is service connected
|
|
S DFN=ACKPAT D ELIG^VADPT S ACKSC=$P(VAEL(3),U,1)
|
|
;
|
|
; Indicates whether the patient has any previous visits
|
|
; with audiometric test scores
|
|
;
|
|
S ACKATS=1
|
|
S ACKX=$O(^ACK(509850.6,"AMD",ACKPAT,0)),ACKD0=$O(^ACK(509850.6,"AMD",ACKPAT,+ACKX,0))
|
|
I 'ACKX!('$D(^ACK(509850.6,+ACKD0,0))) S ACKATS=0
|
|
;
|
|
;
|
|
S ACKAO=0,ACKRAD=0,ACKENV=0,ACKLOSS="",ACKLAMD=""
|
|
I ACKPCE D STATUS
|
|
S:ACKSC ACKQSER=1 S:ACKAO ACKQORG=1
|
|
S:ACKRAD ACKQIR=1 S:ACKENV ACKQECON=1
|
|
;
|
|
D ELIG
|
|
;
|
|
K VASV,VAEL
|
|
;
|
|
Q
|
|
;
|
|
PCE(ACKDIV,ACKVD) ; Sets ACKPCE to 1 if - The send to PCE flag is set
|
|
; (for the division) and the PCE INTERFACE START DATE is before or on
|
|
; the same day as the Visit Date and the INTERFACE WITH PCE flag for
|
|
; the site is set to true.
|
|
N ACKOUT S ACKOUT=0
|
|
I $$GET1^DIQ(509850.8,"1,","2","I") D
|
|
. I $$GET1^DIQ(509850.83,ACKDIV_",1",".03","I"),ACKVD'<$$GET1^DIQ(509850.83,ACKDIV_",1",".08","I") S ACKOUT=1
|
|
Q ACKOUT
|
|
;
|
|
;-----
|
|
STATUS ; Sets Agent orange, Radiation and Environmental Contaiment indicators
|
|
; if present.
|
|
;
|
|
; Agent Orange and Radiation
|
|
D SVC^VADPT S ACKAO=VASV(2),ACKRAD=VASV(3)
|
|
;
|
|
; Environmental Contaminents
|
|
S ACKENV=$$GET1^DIQ(2,ACKPAT,.322013,"I")
|
|
I ACKENV="Y" S ACKENV=1
|
|
S:ACKENV'="1" ACKENV=0
|
|
Q
|
|
;-----
|
|
;
|
|
AUDIO() ; Pass back 1 if user is valid to enter audimetric scores else 0
|
|
;
|
|
I ACKCP=1 Q 1
|
|
I ACKLOSS,'ACKBA Q 1
|
|
Q 0
|
|
;
|
|
;-----
|
|
;
|
|
ELIG ; Set up eligibiliy variables and if more than one eligibility create
|
|
; display array used in block ELIGDISP
|
|
;
|
|
; If not service connected set default to primary & file in visit rec.
|
|
I $P(VAEL(3),U,1)=0 D Q
|
|
. S ACKELGCT=1,ACKELIG=$P(VAEL(1),U,2),ACKELIG1=$P(VAEL(1),U,1)
|
|
. K ACKAR S ACKAR(509850.6,ACKVIEN_",",80)=ACKELIG1
|
|
. D FILE^DIE("K","ACKAR") K ACKAR Q
|
|
;
|
|
S ACKVELG=$$GET1^DIQ(509850.6,ACKVIEN,80,"I") I $G(ACKVELG)'="" D
|
|
. S ACKVELG=ACKVELG_"^"_$$GET1^DIQ(8,ACKVELG,.01,"I")
|
|
;
|
|
; Set default eligibility
|
|
S ACKELIG=$S($G(ACKVELG)'="":$P(ACKVELG,U,2),1:$P(VAEL(1),U,2))
|
|
;
|
|
; Set up display array
|
|
;
|
|
K ACKELDIS S ACKELGCT=0
|
|
;
|
|
I $G(ACKVELG)'="" S ACKELDIS($P(ACKVELG,U,1))=ACKVELG,ACKELGCT=ACKELGCT+1
|
|
S ACKELDIS($P(VAEL(1),U,1))=VAEL(1),ACKELGCT=ACKELGCT+1
|
|
;
|
|
S ACKK2=""
|
|
F S ACKK2=$O(VAEL(1,ACKK2)) Q:ACKK2="" D
|
|
.S ACKELGCT=ACKELGCT+1
|
|
.S ACKELDIS($P(VAEL(1,ACKK2),U,1))=VAEL(1,ACKK2)
|
|
;
|
|
; If not already set up add NSC internal number 5
|
|
I '$D(ACKELDIS(5)) S ACKELGCT=ACKELGCT+1,ACKELDIS(5)="5^NSC"
|
|
;
|
|
Q
|
|
;
|
|
ELIGDIS ; Display patients eligibilities
|
|
;
|
|
N ACKK2,RC
|
|
D ENS^%ZISS
|
|
S RC=$$PAGE^ACKQNQ(6) Q:RC<0 W:'RC !!
|
|
W IOUON,"This Patient has other Entitled Eligibilities",IOUOFF,!!
|
|
S ACKK2=""
|
|
F S ACKK2=$O(ACKELDIS(ACKK2)) Q:ACKK2="" D Q:RC<0
|
|
.Q:$P(ACKELDIS(ACKK2),U,2)=ACKELIG
|
|
.S RC=$$PAGE^ACKQNQ(2) Q:RC<0
|
|
.W:RC IOUON,"Other Entitled Eligibilities (cont'd)",IOUOFF,!!
|
|
.W ?1,$P(ACKELDIS(ACKK2),U,2)_" "
|
|
.W $$GET1^DIQ(8,ACKK2,5),!
|
|
Q
|
|
;-----
|
|
; Display Patient data concerning Rated Disabilities and service clas.
|
|
PATDIS ;
|
|
S DFN=ACKPAT D RATDIS^ACKQNQ
|
|
D CLASDIS^ACKQNQ
|
|
Q
|
|
;
|
|
ACKCP() ; This initialises the C&P Paramter.
|
|
; First check site parameteres file for C&P flag
|
|
;
|
|
I '$$GET1^DIQ(509850.83,ACKDIV_",1",".06","I") Q 0
|
|
;
|
|
; Check if C&P has an open request pass back 1 or 0
|
|
S ACKQCPS=$$EN1^DVBCTRN(ACKPAT,"AUDIO")
|
|
S:ACKQCPS>0 ACKQCPS=$P(ACKQCPS,U)
|
|
I $S(ACKCSC'="A":1,$$EN1^DVBCTRN(ACKPAT,"AUDIO",ACKQCPS)<1:1,$O(^ACK(509850.6,"ALCP",ACKQCPS,0))=ACKVIEN:0,$D(^ACK(509850.6,"ALCP",ACKQCPS)):1,1:0) Q 0
|
|
Q "1^"_ACKQCPS
|
|
;
|
|
;-----
|
|
PROVDIS ; Get providers already filed and display
|
|
;
|
|
N RC
|
|
D ENS^%ZISS
|
|
N ACKK1,ACKPROV,ACKK2,D0,ACKARR,ACKTGT,ACKMSG
|
|
D LIST^DIC(509850.66,","_ACKVIEN_",",".01","","*","","","","","","ACKTGT","ACKMSG")
|
|
S ACKK1=""
|
|
F S ACKK1=$O(ACKTGT("DILIST",1,ACKK1)) Q:ACKK1="" D
|
|
. S ACKARR(ACKK1)=ACKTGT("DILIST",1,ACKK1)
|
|
K ACKPROV S ACKK2=ACKVIEN_","
|
|
D GETS^DIQ(509850.6,ACKK2,"6;7","E","ACKPROV")
|
|
I '$D(ACKARR),$G(ACKPROV(509850.6,ACKK2,"6","E"))="",$G(ACKPROV(509850.6,ACKK2,"7","E"))="" Q
|
|
S RC=$$PAGE^ACKQNQ(5) Q:RC<0 W:'RC !!
|
|
W " ",IOUON,"Providers currently recorded for this visit",IOUOFF,!
|
|
I $G(ACKPROV(509850.6,ACKK2,"6","E"))'="" W !," Primary Provider - "_ACKPROV(509850.6,ACKK2,"6","E")
|
|
I $D(ACKARR)>1 S RC=0 D Q:RC<0
|
|
. S ACKK1=""
|
|
. F S ACKK1=$O(ACKARR(ACKK1)) Q:ACKK1="" D Q:RC<0
|
|
. . S RC=$$PAGE^ACKQNQ(2) Q:RC<0
|
|
. . W !," Secondary Provider - "_ACKARR(ACKK1)
|
|
D:$G(ACKPROV(509850.6,ACKK2,"7","E"))'=""
|
|
. S RC=$$PAGE^ACKQNQ(2) Q:RC<0
|
|
. W !," Student - "_ACKPROV(509850.6,ACKK2,"7","E")
|
|
W !
|
|
Q
|
|
;
|
|
CPTDIS ; Get procedures already filed and display
|
|
;
|
|
D ENS^%ZISS
|
|
N D0,ACKKEY,ACKCPTDS,ACKK3,ACKPIEN,ACKTMOD,ACKCODE,ACKPROC,ACKPRV
|
|
D LIST^DIC(509850.61,","_ACKVIEN_",",".01;.03;.05","I","*","","","","","","ACKCPTDS")
|
|
I '$D(ACKCPTDS("DILIST",1)) Q
|
|
W !!," ",IOUON,"Procedures currently entered for this visit",IOUOFF,!
|
|
S ACKK3=""
|
|
F S ACKK3=$O(ACKCPTDS("DILIST",1,ACKK3)) Q:ACKK3="" D
|
|
. S ACKPROC=ACKCPTDS("DILIST",1,ACKK3)
|
|
. S ACKPRV=ACKCPTDS("DILIST","ID",ACKK3,.05)
|
|
. I ACKPRV'="" S ACKPRV=$$CONVERT(ACKPRV)
|
|
. W !," Code: ",$$GET1^DIQ(509850.4,ACKPROC_",",.01),?19,"Volume: ",ACKCPTDS("DILIST","ID",ACKK3,.03) I ACKPRV'="" W " Provider : ",ACKPRV
|
|
. D LONG^ACKQUTL6(ACKPROC,"1")
|
|
. W !
|
|
. ; Check if any Modifiers present for this Procedure
|
|
. S ACKPIEN="" I $D(ACKCODE(ACKPROC)) S ACKPIEN=$O(ACKCODE(ACKPROC,""),-1)
|
|
. S ACKPIEN=$O(^ACK(509850.6,ACKVIEN,3,"B",ACKPROC,ACKPIEN))
|
|
. I ACKPIEN="" W ! Q
|
|
. S ACKCODE(ACKPROC,ACKPIEN)=""
|
|
. ; Modifier level present do a LIST to get them
|
|
. S ACKPIEN=ACKPIEN_","_ACKVIEN
|
|
. D LIST^DIC(509850.64,","_ACKPIEN_",",".01","I","*","","","","","","ACKTMOD")
|
|
. I $D(ACKTMOD("DILIST",1)) D
|
|
. . W " Modifiers:"
|
|
. . ; Loop through Modifier Array
|
|
. . S ACKKEY=""
|
|
. . F S ACKKEY=$O(ACKTMOD("DILIST",1,ACKKEY)) Q:ACKKEY="" D
|
|
. . . W ?19,$$MODTXT^ACKQUTL8(ACKTMOD("DILIST",1,ACKKEY),ACKVD),!
|
|
. . K ACKTMOD
|
|
W !
|
|
Q
|
|
;
|
|
DIAGDIS ; Get diagnoses already filed and display
|
|
D ENS^%ZISS
|
|
N ACK1,D0,ACKDIAGD,ACKK3,ACKK4,ACKI,ACKD,RC
|
|
D LIST^DIC(509850.63,","_ACKVIEN_",",".01;.12","I","*","","","","","","ACKDIAGD")
|
|
I '$D(ACKDIAGD("DILIST",1)) Q
|
|
S RC=$$PAGE^ACKQNQ(5) Q:RC<0 W:'RC !!
|
|
W " ",IOUON,"Diagnoses currently entered for this visit:",IOUOFF,!
|
|
S ACKK3="",ACKSP=" "
|
|
F S ACKK3=$O(ACKDIAGD("DILIST",1,ACKK3)) Q:ACKK3="" D
|
|
. S ACKK4=ACKDIAGD("DILIST",1,ACKK3)
|
|
. S ACKI=$$GET1^DIQ(80,ACKK4,.01)
|
|
. S ACKD($S(ACKI?.NP:+ACKI,1:ACKI))=ACKI_$E(" ",1,7-$L(ACKI))_"- "_$E($$DIAGTXT^ACKQUTL8(ACKK4,ACKVD)_ACKSP,1,35)_$S($G(ACKDIAGD("DILIST","ID",ACKK3,".12"))=1:" * Primary Diagnosis *",1:" * Secondary Diagnosis *")
|
|
;
|
|
S ACK1=""
|
|
F S ACK1=$O(ACKD(ACK1)) Q:ACK1="" D
|
|
. S RC=$$PAGE^ACKQNQ(3) Q:RC<0
|
|
. W:RC IOUON,"Diagnoses currently entered for this visit (cont'd)",IOUOFF,!
|
|
. W !," ",ACKD(ACK1)
|
|
W !
|
|
Q
|
|
;
|
|
;
|
|
HLOSS ; Sets hearing loss variable if one or more diagnosis are for hearing
|
|
; loss
|
|
;
|
|
N ACKK4,ACKDIAG
|
|
S (ACKLOSS,ACKK4)=0
|
|
F S ACKK4=$O(^ACK(509850.6,ACKVIEN,1,ACKK4)) Q:ACKK4'?1.N!(ACKLOSS) D
|
|
.S ACKDIAG=$P(^ACK(509850.6,ACKVIEN,1,ACKK4,0),U,1)
|
|
.I $P(^ACK(509850.1,ACKDIAG,0),U,5)=1 S ACKLOSS=1 Q
|
|
Q
|
|
;
|
|
MODDIS ; Display Modifiers - Called within Executable Help of Modiifer
|
|
; Enter Edit.
|
|
S ACK1="0"
|
|
F S ACK1=$O(^ACK(509850.5,ACK1)) Q:'+ACK1 D
|
|
. W !," "_$$GET1^DIQ(81.3,ACK1,.01),?5,$$MODTXT^ACKQUTL8(ACK1,""),?53,$$GET1^DIQ(81.3,ACK1,.04)
|
|
W ! Q
|
|
;
|
|
CONVERT(ACKPRV) ; Converts the QSR Prov Code into a name string from file 200.
|
|
;
|
|
N ACKPRV1,ACKPRV2
|
|
S ACKPRV1=$P(^ACK(509850.3,ACKPRV,0),U,1)
|
|
S ACKPRV2=$P(^USR(8930.3,ACKPRV1,0),U,1)
|
|
Q $$GET1^DIQ(200,ACKPRV2_",",.01)
|
|
;
|
|
CONVERT1(ACKPRV) ; Converts the Provider IEN number used within Quasar
|
|
; to its equivalent code used on the 200 file.
|
|
N ACKPRV1
|
|
S ACKPRV1=$P(^ACK(509850.3,ACKPRV,0),U,1)
|
|
Q $P(^USR(8930.3,ACKPRV1,0),U,1)
|
|
;
|
|
CONVERT2(ACKPRV) ; Converts the Provider IEN number used within Quasar
|
|
; to its equivalent code used on the 200 file.
|
|
N ACKPRV1
|
|
S ACKPRV1=$P(^ACK(509850.3,ACKPRV,0),U,1)
|
|
Q $P($G(^USR(8930.3,ACKPRV1,0)),U,1)
|