ACKQUTL4 ;HCIOFO/BH - NEW/EDIT Visit Template Utilities for QUASAR ;11/13/08 12:57pm
;;3.0;QUASAR;**1,8,14,17,16,22,21**;Feb 11, 2000;Build 40
;Per VHA Directive 2004-038, this routine SHOULD NOT be modified.
;
;Reference/IA
;GETCUR^DGNTAPI/3457
;CVEDT^DGCV/4156
;$$CODEC^ICDEX - 5747
;$$MOD^ICPTMOD - 1996
;
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 appears
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,ACKRAD,ACKENV,ACKHNC,ACKCV)=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 Contaminant and Combat indicators
; AO,Rad
D SVC^VADPT S ACKAO=VASV(2),ACKRAD=VASV(3)
; Combat Veteran
; DBIA 4156
S:$G(ACKVD) ACKCV=+$P($$CVEDT^DGCV(ACKPAT,ACKVD),U,3)
; HNC
N ACKHNC0
D GETCUR^DGNTAPI(DFN,"ACKHNC0")
S ACKHNC=$S((".3.4.5."[("."_$P($G(ACKHNC0("STAT")),U)_".")):1,1:0)
; ENV
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 class.
PATDIS ;
S DFN=ACKPAT D RATDIS^ACKQNQ
D CLASDIS^ACKQNQ
Q
;
ACKCP() ; This initializes the C&P Parameter.
; First check site parameters 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)
. ;ACKQ*3.0*22 updated api
. S ACKI=$$CODEC^ICDEX(80,ACKK4)
. 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.
N ACKSRCE
S ACK1="0"
F S ACK1=$O(^ACK(509850.5,ACK1)) Q:'+ACK1 D
. ;ACKQ*3.0*22 updated api
. S ACKSRCE=$P($$MOD^ICPTMOD(ACK1,"I"),U,5)
. W !," "_$P($$MOD^ICPTMOD(ACK1,"I"),U,2),?5,$$MODTXT^ACKQUTL8(ACK1,""),?53,$S(ACKSRCE="C":"CPT",ACKSRCE="H":"HCPCS",ACKSRCE="V":"VA NATIONAL",1:"")
W ! Q
;
CONVERT(ACKPRV) ; Converts the QSR Prov Code into a name string from file 200.
;
;ACKQ*3*17
Q $$GET1^DIQ(509850.3,ACKPRV,.07)
;
CONVERT1(ACKPRV) ; Converts the Provider IEN number used within Quasar
; to its equivalent code used on the 200 file.
;ACKQ*3*17
Q +$$GET1^DIQ(509850.3,ACKPRV,.07,"I")
;
CONVERT2(ACKPRV) ; Converts the Provider IEN number used within Quasar
; to its equivalent code used on the 200 file.
;ACKQ*3*17
Q +$$GET1^DIQ(509850.3,ACKPRV,.07,"I")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQUTL4 10187 printed Apr 09, 2024@21:35:32 Page 2
ACKQUTL4 ;HCIOFO/BH - NEW/EDIT Visit Template Utilities for QUASAR ;11/13/08 12:57pm
+1 ;;3.0;QUASAR;**1,8,14,17,16,22,21**;Feb 11, 2000;Build 40
+2 ;Per VHA Directive 2004-038, this routine SHOULD NOT be modified.
+3 ;
+4 ;Reference/IA
+5 ;GETCUR^DGNTAPI/3457
+6 ;CVEDT^DGCV/4156
+7 ;$$CODEC^ICDEX - 5747
+8 ;$$MOD^ICPTMOD - 1996
+9 ;
CHK(Y,ACKVD) ;
+1 NEW ACKQQD
+2 SET ACKQQD=$PIECE(^EC(725,Y,0),"^",3)
IF ACKQQD=""
QUIT 1
+3 IF ACKVD<ACKQQD
QUIT 1
+4 QUIT 0
+5 ; Clears passed in field # of visit rec.
CLEAR(ACKVIEN,ACKZNUM) ;
+1 NEW ACKARR
+2 SET ACKARR(509850.6,ACKVIEN_",",ACKZNUM)=""
+3 DO FILE^DIE("","ACKARR","")
+4 QUIT
+5 ; Decides if patient is/was suffering from MST at the time of the visit
MST(ACKPCE,ACKVD,ACKPAT) ;
+1 IF '$$PATCH^XPDUTL("DG*5.3*308")
QUIT 0
+2 IF ACKPCE'=1
QUIT 0
+3 NEW ACKRET,ACKXKEEP
+4 SET ACKXKEEP=X
+5 SET ACKRET=$$GETSTAT^DGMSTAPI(ACKPAT,ACKVD)
+6 SET X=ACKXKEEP
+7 IF $PIECE(ACKRET,"^",2)="Y"
QUIT 1
+8 QUIT 0
+9 ;
PROB(ACKPCE,ACKDIV) ; Decides if Update PCE Problem List prompt appears
+1 IF 'ACKPCE
QUIT 0
+2 IF '$$GET1^DIQ(509850.83,ACKDIV_",1",".09","I")
QUIT 0
+3 QUIT 1
+4 ;
SETUP ; Called from within the New/Edit visit template to set up parameters
+1 ;
+2 DO ENS^%ZISS
+3 ;
+4 IF ACKVISIT="EDIT"
Begin DoDot:1
+5 KILL ACKAR
+6 SET ACKAR(509850.6,ACKVIEN_",",.27)=""
+7 DO FILE^DIE("K","ACKAR")
KILL ACKAR
End DoDot:1
+8 ;
+9 NEW ACKX,ACKD0
+10 ;
+11 SET (ICPTVDT,ICDVDT)=ACKVD
+12 ;
+13 ; Sets PCE indicator
SET ACKPCE=$$PCE(ACKDIV,ACKVD)
+14 ;
+15 SET ACKEVENT=1
+16 ; Use EC Codes or CPT
SET ACKEVENT=$$EVENT^ACKQUTL5(ACKDIV,ACKVD)
+17 ; Indicates whether local clinic #'s are in use
+18 SET ACKCLNO=$$GET1^DIQ(509850.83,ACKDIV_",1",".04","I")
+19 ;
+20 ; Indicates whether the bypass flag for Audiometrics is set
+21 SET ACKBA=$$GET1^DIQ(509850.83,ACKDIV_",1",".07","I")
+22 ;
+23 ; Indicates whether the visit is service connected
+24 SET DFN=ACKPAT
DO ELIG^VADPT
SET ACKSC=$PIECE(VAEL(3),U,1)
+25 ;
+26 ; Indicates whether the patient has any previous visits
+27 ; with audiometric test scores
+28 ;
+29 SET ACKATS=1
+30 SET ACKX=$ORDER(^ACK(509850.6,"AMD",ACKPAT,0))
SET ACKD0=$ORDER(^ACK(509850.6,"AMD",ACKPAT,+ACKX,0))
+31 IF 'ACKX!('$DATA(^ACK(509850.6,+ACKD0,0)))
SET ACKATS=0
+32 ;
+33 SET (ACKAO,ACKRAD,ACKENV,ACKHNC,ACKCV)=0
SET (ACKLOSS,ACKLAMD)=""
+34 IF ACKPCE
DO STATUS
+35 if ACKSC
SET ACKQSER=1
if ACKAO
SET ACKQORG=1
+36 if ACKRAD
SET ACKQIR=1
if ACKENV
SET ACKQECON=1
+37 ;
+38 DO ELIG
+39 ;
+40 KILL VASV,VAEL
+41 ;
+42 QUIT
+43 ;
PCE(ACKDIV,ACKVD) ; Sets ACKPCE to 1 if - The send to PCE flag is set
+1 ; (for the division) and the PCE INTERFACE START DATE is before or on
+2 ; the same day as the Visit Date and the INTERFACE WITH PCE flag for
+3 ; the site is set to true.
+4 NEW ACKOUT
SET ACKOUT=0
+5 IF $$GET1^DIQ(509850.8,"1,","2","I")
Begin DoDot:1
+6 IF $$GET1^DIQ(509850.83,ACKDIV_",1",".03","I")
IF ACKVD'<$$GET1^DIQ(509850.83,ACKDIV_",1",".08","I")
SET ACKOUT=1
End DoDot:1
+7 QUIT ACKOUT
+8 ;
STATUS ; Sets Agent orange, Radiation and Environmental Contaminant and Combat indicators
+1 ; AO,Rad
+2 DO SVC^VADPT
SET ACKAO=VASV(2)
SET ACKRAD=VASV(3)
+3 ; Combat Veteran
+4 ; DBIA 4156
+5 if $GET(ACKVD)
SET ACKCV=+$PIECE($$CVEDT^DGCV(ACKPAT,ACKVD),U,3)
+6 ; HNC
+7 NEW ACKHNC0
+8 DO GETCUR^DGNTAPI(DFN,"ACKHNC0")
+9 SET ACKHNC=$SELECT((".3.4.5."[("."_$PIECE($GET(ACKHNC0("STAT")),U)_".")):1,1:0)
+10 ; ENV
+11 SET ACKENV=$$GET1^DIQ(2,ACKPAT,.322013,"I")
+12 IF ACKENV="Y"
SET ACKENV=1
+13 if ACKENV'="1"
SET ACKENV=0
+14 QUIT
+15 ;-----
+16 ;
AUDIO() ; Pass back 1 if user is valid to enter audimetric scores else 0
+1 ;
+2 IF ACKCP=1
QUIT 1
+3 IF ACKLOSS
IF 'ACKBA
QUIT 1
+4 QUIT 0
+5 ;
+6 ;-----
+7 ;
ELIG ; Set up eligibiliy variables and if more than one eligibility create
+1 ; display array used in block ELIGDISP
+2 ;
+3 ; If not service connected set default to primary & file in visit rec.
+4 IF $PIECE(VAEL(3),U,1)=0
Begin DoDot:1
+5 SET ACKELGCT=1
SET ACKELIG=$PIECE(VAEL(1),U,2)
SET ACKELIG1=$PIECE(VAEL(1),U,1)
+6 KILL ACKAR
SET ACKAR(509850.6,ACKVIEN_",",80)=ACKELIG1
+7 DO FILE^DIE("K","ACKAR")
KILL ACKAR
QUIT
End DoDot:1
QUIT
+8 ;
+9 SET ACKVELG=$$GET1^DIQ(509850.6,ACKVIEN,80,"I")
IF $GET(ACKVELG)'=""
Begin DoDot:1
+10 SET ACKVELG=ACKVELG_"^"_$$GET1^DIQ(8,ACKVELG,.01,"I")
End DoDot:1
+11 ;
+12 ; Set default eligibility
+13 SET ACKELIG=$SELECT($GET(ACKVELG)'="":$PIECE(ACKVELG,U,2),1:$PIECE(VAEL(1),U,2))
+14 ;
+15 ; Set up display array
+16 ;
+17 KILL ACKELDIS
SET ACKELGCT=0
+18 ;
+19 IF $GET(ACKVELG)'=""
SET ACKELDIS($PIECE(ACKVELG,U,1))=ACKVELG
SET ACKELGCT=ACKELGCT+1
+20 SET ACKELDIS($PIECE(VAEL(1),U,1))=VAEL(1)
SET ACKELGCT=ACKELGCT+1
+21 ;
+22 SET ACKK2=""
+23 FOR
SET ACKK2=$ORDER(VAEL(1,ACKK2))
if ACKK2=""
QUIT
Begin DoDot:1
+24 SET ACKELGCT=ACKELGCT+1
+25 SET ACKELDIS($PIECE(VAEL(1,ACKK2),U,1))=VAEL(1,ACKK2)
End DoDot:1
+26 ;
+27 ; If not already set up add NSC internal number 5
+28 IF '$DATA(ACKELDIS(5))
SET ACKELGCT=ACKELGCT+1
SET ACKELDIS(5)="5^NSC"
+29 ;
+30 QUIT
+31 ;
ELIGDIS ; Display patients eligibilities
+1 ;
+2 NEW ACKK2,RC
+3 DO ENS^%ZISS
+4 SET RC=$$PAGE^ACKQNQ(6)
if RC<0
QUIT
if 'RC
WRITE !!
+5 WRITE IOUON,"This Patient has other Entitled Eligibilities",IOUOFF,!!
+6 SET ACKK2=""
+7 FOR
SET ACKK2=$ORDER(ACKELDIS(ACKK2))
if ACKK2=""
QUIT
Begin DoDot:1
+8 if $PIECE(ACKELDIS(ACKK2),U,2)=ACKELIG
QUIT
+9 SET RC=$$PAGE^ACKQNQ(2)
if RC<0
QUIT
+10 if RC
WRITE IOUON,"Other Entitled Eligibilities (cont'd)",IOUOFF,!!
+11 WRITE ?1,$PIECE(ACKELDIS(ACKK2),U,2)_" "
+12 WRITE $$GET1^DIQ(8,ACKK2,5),!
End DoDot:1
if RC<0
QUIT
+13 QUIT
+14 ;-----
+15 ; Display Patient data concerning Rated Disabilities and service class.
PATDIS ;
+1 SET DFN=ACKPAT
DO RATDIS^ACKQNQ
+2 DO CLASDIS^ACKQNQ
+3 QUIT
+4 ;
ACKCP() ; This initializes the C&P Parameter.
+1 ; First check site parameters file for C&P flag
+2 ;
+3 IF '$$GET1^DIQ(509850.83,ACKDIV_",1",".06","I")
QUIT 0
+4 ;
+5 ; Check if C&P has an open request pass back 1 or 0
+6 SET ACKQCPS=$$EN1^DVBCTRN(ACKPAT,"AUDIO")
+7 if ACKQCPS>0
SET ACKQCPS=$PIECE(ACKQCPS,U)
+8 IF $SELECT(ACKCSC'="A":1,$$EN1^DVBCTRN(ACKPAT,"AUDIO",ACKQCPS)<1:1,$ORDER(^ACK(509850.6,"ALCP",ACKQCPS,0))=ACKVIEN:0,$DATA(^ACK(509850.6,"ALCP",ACKQCPS)):1,1:0)
QUIT 0
+9 QUIT "1^"_ACKQCPS
+10 ;
+11 ;-----
PROVDIS ; Get providers already filed and display
+1 ;
+2 NEW RC
+3 DO ENS^%ZISS
+4 NEW ACKK1,ACKPROV,ACKK2,D0,ACKARR,ACKTGT,ACKMSG
+5 DO LIST^DIC(509850.66,","_ACKVIEN_",",".01","","*","","","","","","ACKTGT","ACKMSG")
+6 SET ACKK1=""
+7 FOR
SET ACKK1=$ORDER(ACKTGT("DILIST",1,ACKK1))
if ACKK1=""
QUIT
Begin DoDot:1
+8 SET ACKARR(ACKK1)=ACKTGT("DILIST",1,ACKK1)
End DoDot:1
+9 KILL ACKPROV
SET ACKK2=ACKVIEN_","
+10 DO GETS^DIQ(509850.6,ACKK2,"6;7","E","ACKPROV")
+11 IF '$DATA(ACKARR)
IF $GET(ACKPROV(509850.6,ACKK2,"6","E"))=""
IF $GET(ACKPROV(509850.6,ACKK2,"7","E"))=""
QUIT
+12 SET RC=$$PAGE^ACKQNQ(5)
if RC<0
QUIT
if 'RC
WRITE !!
+13 WRITE " ",IOUON,"Providers currently recorded for this visit",IOUOFF,!
+14 IF $GET(ACKPROV(509850.6,ACKK2,"6","E"))'=""
WRITE !," Primary Provider - "_ACKPROV(509850.6,ACKK2,"6","E")
+15 IF $DATA(ACKARR)>1
SET RC=0
Begin DoDot:1
+16 SET ACKK1=""
+17 FOR
SET ACKK1=$ORDER(ACKARR(ACKK1))
if ACKK1=""
QUIT
Begin DoDot:2
+18 SET RC=$$PAGE^ACKQNQ(2)
if RC<0
QUIT
+19 WRITE !," Secondary Provider - "_ACKARR(ACKK1)
End DoDot:2
if RC<0
QUIT
End DoDot:1
if RC<0
QUIT
+20 if $GET(ACKPROV(509850.6,ACKK2,"7","E"))'=""
Begin DoDot:1
+21 SET RC=$$PAGE^ACKQNQ(2)
if RC<0
QUIT
+22 WRITE !," Student - "_ACKPROV(509850.6,ACKK2,"7","E")
End DoDot:1
+23 WRITE !
+24 QUIT
+25 ;
CPTDIS ; Get procedures already filed and display
+1 ;
+2 DO ENS^%ZISS
+3 NEW D0,ACKKEY,ACKCPTDS,ACKK3,ACKPIEN,ACKTMOD,ACKCODE,ACKPROC,ACKPRV
+4 DO LIST^DIC(509850.61,","_ACKVIEN_",",".01;.03;.05","I","*","","","","","","ACKCPTDS")
+5 IF '$DATA(ACKCPTDS("DILIST",1))
QUIT
+6 WRITE !!," ",IOUON,"Procedures currently entered for this visit",IOUOFF,!
+7 SET ACKK3=""
+8 FOR
SET ACKK3=$ORDER(ACKCPTDS("DILIST",1,ACKK3))
if ACKK3=""
QUIT
Begin DoDot:1
+9 SET ACKPROC=ACKCPTDS("DILIST",1,ACKK3)
+10 SET ACKPRV=ACKCPTDS("DILIST","ID",ACKK3,.05)
+11 IF ACKPRV'=""
SET ACKPRV=$$CONVERT(ACKPRV)
+12 WRITE !," Code: ",$$GET1^DIQ(509850.4,ACKPROC_",",.01),?19,"Volume: ",ACKCPTDS("DILIST","ID",ACKK3,.03)
IF ACKPRV'=""
WRITE " Provider : ",ACKPRV
+13 DO LONG^ACKQUTL6(ACKPROC,"1")
+14 WRITE !
+15 ; Check if any Modifiers present for this Procedure
+16 SET ACKPIEN=""
IF $DATA(ACKCODE(ACKPROC))
SET ACKPIEN=$ORDER(ACKCODE(ACKPROC,""),-1)
+17 SET ACKPIEN=$ORDER(^ACK(509850.6,ACKVIEN,3,"B",ACKPROC,ACKPIEN))
+18 IF ACKPIEN=""
WRITE !
QUIT
+19 SET ACKCODE(ACKPROC,ACKPIEN)=""
+20 ; Modifier level present do a LIST to get them
+21 SET ACKPIEN=ACKPIEN_","_ACKVIEN
+22 DO LIST^DIC(509850.64,","_ACKPIEN_",",".01","I","*","","","","","","ACKTMOD")
+23 IF $DATA(ACKTMOD("DILIST",1))
Begin DoDot:2
+24 WRITE " Modifiers:"
+25 ; Loop through Modifier Array
+26 SET ACKKEY=""
+27 FOR
SET ACKKEY=$ORDER(ACKTMOD("DILIST",1,ACKKEY))
if ACKKEY=""
QUIT
Begin DoDot:3
+28 WRITE ?19,$$MODTXT^ACKQUTL8(ACKTMOD("DILIST",1,ACKKEY),ACKVD),!
End DoDot:3
+29 KILL ACKTMOD
End DoDot:2
End DoDot:1
+30 WRITE !
+31 QUIT
+32 ;
DIAGDIS ; Get diagnoses already filed and display
+1 DO ENS^%ZISS
+2 NEW ACK1,D0,ACKDIAGD,ACKK3,ACKK4,ACKI,ACKD,RC
+3 DO LIST^DIC(509850.63,","_ACKVIEN_",",".01;.12","I","*","","","","","","ACKDIAGD")
+4 IF '$DATA(ACKDIAGD("DILIST",1))
QUIT
+5 SET RC=$$PAGE^ACKQNQ(5)
if RC<0
QUIT
if 'RC
WRITE !!
+6 WRITE " ",IOUON,"Diagnoses currently entered for this visit:",IOUOFF,!
+7 SET ACKK3=""
SET ACKSP=" "
+8 FOR
SET ACKK3=$ORDER(ACKDIAGD("DILIST",1,ACKK3))
if ACKK3=""
QUIT
Begin DoDot:1
+9 SET ACKK4=ACKDIAGD("DILIST",1,ACKK3)
+10 ;ACKQ*3.0*22 updated api
+11 SET ACKI=$$CODEC^ICDEX(80,ACKK4)
+12 SET ACKD($SELECT(ACKI?.NP:+ACKI,1:ACKI))=ACKI_$EXTRACT(" ",1,7-$LENGTH(ACKI))_"- "_$EXTRACT($$DIAGTXT^ACKQUTL8(ACKK4,ACKVD)_ACKSP,1,35)_$SELECT($GET(ACKDIAGD("DILIST","ID",ACKK3,".12"))=1:" * Primary Diagnosis *",1:" * Secondary Dia
gnosis *")
End DoDot:1
+13 ;
+14 SET ACK1=""
+15 FOR
SET ACK1=$ORDER(ACKD(ACK1))
if ACK1=""
QUIT
Begin DoDot:1
+16 SET RC=$$PAGE^ACKQNQ(3)
if RC<0
QUIT
+17 if RC
WRITE IOUON,"Diagnoses currently entered for this visit (cont'd)",IOUOFF,!
+18 WRITE !," ",ACKD(ACK1)
End DoDot:1
+19 WRITE !
+20 QUIT
+21 ;
+22 ;
HLOSS ; Sets hearing loss variable if one or more diagnosis are for hearing
+1 ; loss
+2 ;
+3 NEW ACKK4,ACKDIAG
+4 SET (ACKLOSS,ACKK4)=0
+5 FOR
SET ACKK4=$ORDER(^ACK(509850.6,ACKVIEN,1,ACKK4))
if ACKK4'?1.N!(ACKLOSS)
QUIT
Begin DoDot:1
+6 SET ACKDIAG=$PIECE(^ACK(509850.6,ACKVIEN,1,ACKK4,0),U,1)
+7 IF $PIECE(^ACK(509850.1,ACKDIAG,0),U,5)=1
SET ACKLOSS=1
QUIT
End DoDot:1
+8 QUIT
+9 ;
MODDIS ; Display Modifiers - Called within Executable Help of Modiifer
+1 ; Enter Edit.
+2 NEW ACKSRCE
+3 SET ACK1="0"
+4 FOR
SET ACK1=$ORDER(^ACK(509850.5,ACK1))
if '+ACK1
QUIT
Begin DoDot:1
+5 ;ACKQ*3.0*22 updated api
+6 SET ACKSRCE=$PIECE($$MOD^ICPTMOD(ACK1,"I"),U,5)
+7 WRITE !," "_$PIECE($$MOD^ICPTMOD(ACK1,"I"),U,2),?5,$$MODTXT^ACKQUTL8(ACK1,""),?53,$SELECT(ACKSRCE="C":"CPT",ACKSRCE="H":"HCPCS",ACKSRCE="V":"VA NATIONAL",1:"")
End DoDot:1
+8 WRITE !
QUIT
+9 ;
CONVERT(ACKPRV) ; Converts the QSR Prov Code into a name string from file 200.
+1 ;
+2 ;ACKQ*3*17
+3 QUIT $$GET1^DIQ(509850.3,ACKPRV,.07)
+4 ;
CONVERT1(ACKPRV) ; Converts the Provider IEN number used within Quasar
+1 ; to its equivalent code used on the 200 file.
+2 ;ACKQ*3*17
+3 QUIT +$$GET1^DIQ(509850.3,ACKPRV,.07,"I")
+4 ;
CONVERT2(ACKPRV) ; Converts the Provider IEN number used within Quasar
+1 ; to its equivalent code used on the 200 file.
+2 ;ACKQ*3*17
+3 QUIT +$$GET1^DIQ(509850.3,ACKPRV,.07,"I")
+4 ;
