Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACKQUTL4

ACKQUTL4.m

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