- 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 Feb 18, 2025@23:59:24 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 ;