AUPNCIX ; IHS/CMI/LAB - CREATE COMPOUND "AQ" INDICIES LAB&MEAS ; 08 May 2014 5:24 PM
;;2.0;IHS PCC SUITE;**2,10,11**;MAY 14, 2009;Build 58
;; MODIFIED TO SUPPORT Q-MAN 1.3 BY GIS/OHPRD MAY 24,1991
; The old compound index "BA" is no longer created and will be killed
;
VMSR04 ;EP - V MEASUREMENT:MEASUREMENT (9000010.01,.04)
G:X="" EXIT
S AUPNCIXK="AUPNCIX1,AUPNCIX2,AUPNCIXA,AUPNCIXB,AUPNCIXK,AUPNCIXT,AUPNCIXX,AUPNCIXY,AUPNCIXZ,AUPNCIXV"
S AUPNCIXT=$P(^AUTTMSR(+^AUPNVMSR(DA,0),0),U)
S AUPNCIXA="^BP^VC^VU^",AUPNCIXB="^HC^HT^WT^",AUPNCIXZ=U_AUPNCIXT_U
I (AUPNCIXA_AUPNCIXB)'[AUPNCIXZ G EXIT
I AUPNCIXB[AUPNCIXZ D VMSR04X G EXIT
I AUPNCIXA[AUPNCIXZ S AUPNCIXX=$P(X,"/",1),AUPNCIXY=$P(X,"/",2) D @("VMSR04"_AUPNCIXT) G EXIT
W !!,"AUPNCIX:VMSR04 ERROR",!!,"NOTIFY YOUR SUPERVISOR IMMEDIATELY - CROSS REFERENCE IS BAD!!"
;
VMSRPCT ;EP Calls ^AUPNPCT for "AQ" x-ref of .05 percentile field
S AUPNSAVX=X,X="AUPNPCT" X ^%ZOSF("TEST") S X=AUPNSAVX K AUPNSAVX I $T D ^AUPNPCT
Q
;
EXIT ; COMMON ROUTINE EXIT
K @AUPNCIXK
Q
;
VMSR04X S AUPNCIXV=$D(^AUPNVMSR("AQ",AUPNCIXT_$E("000",1,3-$L($P(X,".",1)))_X,DA)) S:AUPNCIXF="S" ^(DA)="" K:AUPNCIXF="K" ^(DA)
Q
;
VMSR04B ; ENTRY POINT MAINTAINED FOR BACKWARD COMPATIBILITY
VMSR04BP S AUPNCIX1="BPS",AUPNCIX2="BPD" G VMSR04XX
VMSR04VU S AUPNCIX1="VUR",AUPNCIX2="VUL" G VMSR04XX
VMSR04VC S AUPNCIX1="VCR",AUPNCIX2="VCL"
VMSR04XX S AUPNCIXV=$D(^AUPNVMSR("AQ",AUPNCIX1_$E("000",1,3-$L(AUPNCIXX))_AUPNCIXX,DA)) S:AUPNCIXF="S" ^(DA)="" K:AUPNCIXF="K" ^(DA)
S AUPNCIXV=$D(^AUPNVMSR("AQ",AUPNCIX2_$E("000",1,3-$L(AUPNCIXY))_AUPNCIXY,DA)) S:AUPNCIXF="S" ^(DA)="" K:AUPNCIXF="K" ^(DA)
Q
;
VMSR01 ;EP V MEASUREMENT:MEASUREMENT (9000010.01,.01)
S AUPNCIXK="AUPNCIX1,AUPNCIX2,AUPNCIXA,AUPNCIXB,AUPNCIXK,AUPNCIXT,AUPNCIXX,AUPNCIXY,AUPNCIXZ,AUPNCIXV"
G:$P(^AUPNVMSR(DA,0),U,4)="" EXIT
S AUPNCIXT=$P(^AUTTMSR(X,0),U)
S AUPNCIXA="^BP^VC^VU^",AUPNCIXB="^HC^HT^WT^",AUPNCIXZ=U_AUPNCIXT_U
I (AUPNCIXA_AUPNCIXB)'[AUPNCIXZ G EXIT
I AUPNCIXB[AUPNCIXZ D VMSR01X G EXIT
I AUPNCIXA[AUPNCIXZ S AUPNCIXX=$P($P(^AUPNVMSR(DA,0),U,4),"/",1),AUPNCIXY=$P($P(^AUPNVMSR(DA,0),U,4),"/",2) D @("VMSR01"_AUPNCIXT) G EXIT
W !!,"AUPNCIX:VMSR01 ERROR",!!,"NOTIFY YOUR SUPERVISOR IMMEDIATELY - CROSS REFERENCE IS BAD!!"
G EXIT
;
;
VMSR01X S AUPNCIXV=$D(^AUPNVMSR("AQ",AUPNCIXT_$E("000",1,3-$L($P($P(^AUPNVMSR(DA,0),U,4),".",1)))_$P(^AUPNVMSR(DA,0),U,4),DA)) S:AUPNCIXF="S" ^(DA)="" K:AUPNCIXF="K" ^(DA)
Q
;
VMSR01B ; ENTRY POINT MAINTAINED FOR BACKWARD COMPATIBILITY
VMSR01BP S AUPNCIX1="BPS",AUPNCIX2="BPD" G VMSR01XX
VMSR01VU S AUPNCIX1="VUR",AUPNCIX2="VUL" G VMSR01XX
VMSR01VC S AUPNCIX1="VCR",AUPNCIX2="VCL"
VMSR01XX S AUPNCIXV=$D(^AUPNVMSR("AQ",AUPNCIX1_$E("000",1,3-$L(AUPNCIXX))_AUPNCIXX,DA)) S:AUPNCIXF="S" ^(DA)="" K:AUPNCIXF="K" ^(DA)
S AUPNCIXV=$D(^AUPNVMSR("AQ",AUPNCIX2_$E("000",1,3-$L(AUPNCIXY))_AUPNCIXY,DA)) S:AUPNCIXF="S" ^(DA)="" K:AUPNCIXF="K" ^(DA)
Q
;
AUTO ; SETS V MEASUREMENT "AQ" XREF WITHOUT CALLING FILEMAN
K ^AUPNVMSR("AQ")
F DA=0:0 S DA=$O(^AUPNVMSR(DA)) Q:'DA S AUPNCIXF="S",AUPNCIXV=$G(^(DA,0)),X=$P(AUPNCIXV,U,4) I X'="" D VMSR04 W "."
Q
AUTO1 ;
;
K ^AUPNVMSR("AQ")
F DA=0:0 S DA=$O(^AUPNVMSR(DA)) Q:'DA S AUPNCIXF="S",AUPNCIXV=^(DA,0),X=$P(^AUPNVMSR(DA,0),U,1) D VMSR01 W "."
Q
;
VLAB04 ;EP - called from input transform on .04 of vlab
;if entry is made from PCC Data entry AND BLRENPUT routine exists
;then apply input tx check on result field
;IHS/TUCSON/LAB - added this sub routine to support lab 5.2 - patch 6 6/23/97
Q:DUZ=.5 ;postmaster - filegram
Q:$D(BLRLINK) ;in lab 5.2
Q:'$D(APCDEIN) ;not in direct data entry
Q:$D(BLRCHKIP) ;override variable is set
Q:'$D(X)
Q:X=""
NEW AUPNX
S AUPNX=X,X="BLRENPUT"
X ^%ZOSF("TEST")
S X=AUPNX
I '$T S X=AUPNX K AUPNX Q
K AUPNX
D ^BLRENPUT
I $D(X) K:$L(X)>200!($L(X)<1)!($D(BLRKILL)) X
I $D(BLRKILL) D EN^DDIOL($C(7)_"Results can not be entered for this test!") K BLRKILL
Q
;
VXAMR(V,RETVAL) ;PEP - send back list of allowable result values
I $G(V)="" Q ""
NEW C,Y,S
K @RETVAL
I $E(V)'?.N S V=$O(^AUTTEXAM("B",V,0))
I 'V Q ""
S C=$P($G(^AUTTEXAM(V,0)),U,2)
I C="" Q ""
S S=0
F Y="A","N","PR","PAP","PA","PO","L","M","H","RF","PS" S X=Y D VXAM04C I $D(X) S S=S+1,@RETVAL@(S)=X_U_$$EXTSET^XBFUNC(9000010.13,.04,X)
Q C
;
VXAM04 ;EP - called from input tx on .04 field of V EXAM
Q:'$D(X)
Q:'$G(DA)
NEW C S C=$P(^AUTTEXAM($P(^AUPNVXAM(DA,0),U),0),U,2)
VXAM04C ;
I X="RF" Q ;referral good for all exam types
I X="PS",(C'=38&(C'=39)) K X Q
I C=38!(C=39),X'="PS" K X Q
I X="PA",C'=34 K X Q
I X="PR",C'=34 K X Q
I X="PAP",C'=34 K X Q
I X="A",C=34 K X Q
I X="A",C=35 K X Q
I X="A",C=36 K X Q
I X="PO",(C'=35&(C'=36)&(C'=99)) K X Q ;TAKE OUT 99
I X="L",(C'=42&(C'=43)) K X Q
I X="M",(C'=42&(C'=43)) K X Q
I X="H",(C'=42&(C'=43)) K X Q
I C=42!(C=43),X'="L",X'="M",X'="H" K X Q
Q
VXAM04H ;EP
D EN^DDIOL("RF (Referral Needed) is a valid choice for all exam types","","!")
D EN^DDIOL("N is a valid for all exam types, except VTE/Newborn Hearing/Suicide Assmt ","","!")
;D EN^DDIOL("and Suicide Assessment","","!")
D EN^DDIOL("PR, PAP, PA are only valid for Intimate Partner Violence exam type","","!")
D EN^DDIOL("A is not valid for Intimate Partner Violence/Alcohol Screening/Depression ","","!")
D EN^DDIOL("Screening/VTE Risk Assessment/Suicide Risk Assessment/Newborn Hearing exam types","","!")
D EN^DDIOL("PO is valid for Depression Screening and Alcohol Screening and BIMS exam types","","!")
D EN^DDIOL("L, M and H are only valid for VTE Risk Assessment/Suicide Risk Assessment exams","","!")
D EN^DDIOL("PS (Pass) is only valid for Newborn Hearing Right and Left","","!")
Q
INPH ;EP - called from help 9000024
D EN^DDIOL("Must begin with a numeric value.")
D EN^DDIOL("Must contain a D for Days, W for Weeks, M for Months or Y for years.")
D EN^DDIOL("Examples: 2W for 2 weeks, 10M for 10 Months, 365D for 365 days, 2Y for 2 years.")
Q
OUTTX(%) ;EP called from input transform
I $G(%)="" Q ""
I %["D" Q +%_" Day"_$S(+%>1:"s",1:"")
I %["M" Q +%_" Month"_$S(+%>1:"s",1:"")
I %["Y" Q +%_" Year"_$S(+%>1:"s",1:"")
I %["W" Q +%_" Week"_$S(+%>1:"s",1:"")
Q %
INP ;EP - called from input transform 9000024
I $G(X)="" K X Q
I '(+X) D EN^DDIOL("Must begin with a numeric value.") K X Q
I "MDYW"'[$E(X,$L(X)) D EN^DDIOL("Must contain a D for Days, W for Weeks, M for Months or Y for Years.") K X Q
Q
CONVDAYS(V) ;EP
NEW VAL
I V="" Q ""
I V["D" Q +V
I V["M" S VAL=+V*30.5 Q $P(VAL,".")
I V["Y" S VAL=+V*365 Q $P(VAL,".")
I V["W" S VAL=+V*7 Q $P(VAL,".")
Q ""
KGLB(V) ;EP
I V="" Q ""
NEW VAL
S VAL=V*2.2046226
Q $P(VAL,".")
KGOZ(V) ;EP
I V="" Q ""
NEW VAL
S VAL=V*2.2046226
S VAL="."_$P(VAL,".",2)
S VAL=VAL*16
Q $$STRIP^XLFSTR($J($P(VAL,5,0)," "))
LBKG(V) ;EP
I V="" Q ""
NEW VAL
S VAL=V*.453592
Q $$STRIP^XLFSTR(VAL," ")
OZ(V) ;EP
NEW VAL
I V="" Q ""
S VAL=$P(V,".",2)
I VAL="" Q 0
S VAL="."_VAL
S VAL=VAL*16
S VAL=$$STRIP^XLFSTR(VAL," ")
Q VAL
CMPLDATE(%) ;EP - called from trigger on TREATMENT PLAN File
I $G(%)="" Q ""
NEW A,B,C
S A=$P(^AUPNTP(%,0),U,3)
I A="" Q ""
S B=$P(^AUPNTP(%,0),U,4)
I B="" Q ""
S C=$$CONVDAYS(B)
Q $$FMADD^XLFDT(A,C)
ICD(Y,N,D) ;EP - called from input transforms
S N=$G(N)
S D=$G(D)
I $$CHK(Y,N,D)
Q:$D(^ICD9(Y))
Q
CHK(Y,N,D) ; SCREEN OUT E CODES AND INACTIVE CODES
I $D(DIFGLINE) Q 1
NEW %,A,I,V
I $G(D) G CHK1
I $G(N) S D=$P($P(^AUPNTP(N,0),U,2),".")
I D="" S D=DT
CHK1 ;
S I=$$IMP^AUPNSICD(D)
S %=$$ICDDX^ICDEX(Y,D,,"I")
I $P(%,U,20)'=I Q 0 ;not correct coding system
S I="CHKDX"_I
G @I
;Q
CHKDX1 ;CODING SYSTEM 1 - ICD9
I $E($P(%,U,2),1)="E" Q 0 ;no E codes
I $$VERSION^XPDUTL("BCSV")]"",'$P(%,U,10) Q 0 ;STATUS IS INACTIVE
I $$VERSION^XPDUTL("BCSV")]"" G CSEX
S A=$P($G(^ICD9(Y,9999999)),U,4),I=$P(^ICD9(Y,0),U,11)
I D]"",I]"",D>I Q 0
I D]"",A]"",D<A Q 0
;
CSEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
I '$D(AUPNSEX) Q 1
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
Q 1
;
CHKDX30 ;coding system 30 - ICD10
I $E($P(%,U,2),1)="V" Q 0 ;no codes V00-Y99 per Leslie Racine.
I $E($P(%,U,2),1)="W" Q 0
I $E($P(%,U,2),1)="X" Q 0
I $E($P(%,U,2),1)="Y" Q 0
I '$P(%,U,10) Q 0 ;STATUS IS INACTIVE
;
CSEX30 ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
I '$D(AUPNSEX) Q 1
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
Q 1
WT ;EP (WEIGHT)
D:X?.E.A.E MWT
Q:'$D(X)
D WTC
;S:$P(X,".",2)?1N.N X=X+.00005,X=$P(X,".",1)_"."_$E($P(X,".",2),1,4)
S X=+X
Q:'$D(X)
K:+X'=X!(X>1000) X
Q:'$D(X)
;K:X-(X\1)#.0625 X
Q
WTC Q:+X=X!(X'[" ")
Q:'(X?1.3N1" "1.2N!(X?1.3N1" "1.2N1"/"1.2N))
I X'["/" Q:+$P(X," ",2)>16 S X=+X+(+$P(X," ",2)/16) Q
Q:+$P($P(X," ",2),"/",1)'<+$P($P(X," ",2),"/",2)
S X=+X+((+$P(X," ",2)/$P($P(X," ",2),"/",2)))
Q
;
MWT ;
NEW AUPNC,AUPNI,AUPNJ
S AUPNJ=$L(X) F AUPNI=1:1:AUPNJ S AUPNC=$E(X,AUPNI) I AUPNC?1A S AUPNC=$S(AUPNC?1L:$C($A(AUPNC)-32),1:AUPNC)
S (AUPNI,AUPNC)="" F AUPNI=1:1:AUPNJ S AUPNC=$E(X,AUPNI) Q:"GK"[AUPNC
I "GK"[AUPNC D @AUPNC
K AUPNC,AUPNI,AUPNJ
Q
MWTC ;
Q:+X=X!(X'[" ")!(X'["/")
K:'(X?1.6N1" "1.2N1"/"1.2N) X
Q:'$D(X)
S X=+X+((+$P(X," ",2)/$P($P(X," ",2),"/",2)))
Q
K ;
I X["/" S X=$P(X,AUPNC,1) D MWTC
Q:'$D(X)
S X=+X
S X=(X*2.2046226)
Q
G ;
I X["/" S X=$P(X,AUPNC,1) D MWTC
Q:'$D(X)
S X=+X
S X=(X*.0022046226)
Q
C ;
I X["/" S X=$P(X,AUPNC,1) D MWTC
Q:'$D(X)
S X=+X
S X=(X*.393701)
Q
;
V4906 ;EP - help
D EN^DDIOL("Select whether the patient has any high risk weight issues.")
D EN^DDIOL("For adults, this might be: <80% IBW; 1 week > 2% weight change;")
D EN^DDIOL("1 month > 5% weight change; 3 months > 7.5% weight change;")
D EN^DDIOL("6 months > 10% weight change. For pediatrics, this might ")
D EN^DDIOL("be: < 80% IBW; Wt < 5%ile; L < 5%ile; Wt/L < 5%ile.")
Q
V4907 ;EP - help
D EN^DDIOL("Select whether the patient has any high risk diagnoses; ")
D EN^DDIOL("for example: acute renal failure; AIDS; bone marrow transplant; ")
D EN^DDIOL("new-onset diabetes; pancreatitis; sepsis; congenital heart ")
D EN^DDIOL("disease; failure to thrive; high risk pregnancy.")
Q
NY(%) ;EP - called from computed field
I $G(%)="" Q ""
I '$D(^AUPNVNTS(%,0)) Q ""
NEW T,A
S T=0
F A=4:1:12 S T=T+$P(^AUPNVNTS(%,0),U,A)
Q T
DURENDDT(%) ;EP - called from trigger on V ANTI-COAG File
I $G(%)="" Q ""
NEW A,B,C
S A=$P(^AUPNVACG(%,0),U,7)
I A="" Q ""
S B=$P(^AUPNVACG(%,0),U,8)
I B="" Q ""
S C=$$CONVDUR(A)
I C="" Q ""
Q $$FMADD^XLFDT(B,C)
CONVDUR(B) ;
I B=1 Q 90
I B=2 Q 180
I B=3 Q 365
Q ""
AUPNCIX ; IHS/CMI/LAB - CREATE COMPOUND "AQ" INDICIES LAB&MEAS ; 08 May 2014 5:24 PM
+1 ;;2.0;IHS PCC SUITE;**2,10,11**;MAY 14, 2009;Build 58
+2 ;; MODIFIED TO SUPPORT Q-MAN 1.3 BY GIS/OHPRD MAY 24,1991
+3 ; The old compound index "BA" is no longer created and will be killed
+4 ;
VMSR04 ;EP - V MEASUREMENT:MEASUREMENT (9000010.01,.04)
+1 IF X=""
GOTO EXIT
+2 SET AUPNCIXK="AUPNCIX1,AUPNCIX2,AUPNCIXA,AUPNCIXB,AUPNCIXK,AUPNCIXT,AUPNCIXX,AUPNCIXY,AUPNCIXZ,AUPNCIXV"
+3 SET AUPNCIXT=$PIECE(^AUTTMSR(+^AUPNVMSR(DA,0),0),U)
+4 SET AUPNCIXA="^BP^VC^VU^"
SET AUPNCIXB="^HC^HT^WT^"
SET AUPNCIXZ=U_AUPNCIXT_U
+5 IF (AUPNCIXA_AUPNCIXB)'[AUPNCIXZ
GOTO EXIT
+6 IF AUPNCIXB[AUPNCIXZ
DO VMSR04X
GOTO EXIT
+7 IF AUPNCIXA[AUPNCIXZ
SET AUPNCIXX=$PIECE(X,"/",1)
SET AUPNCIXY=$PIECE(X,"/",2)
DO @("VMSR04"_AUPNCIXT)
GOTO EXIT
+8 WRITE !!,"AUPNCIX:VMSR04 ERROR",!!,"NOTIFY YOUR SUPERVISOR IMMEDIATELY - CROSS REFERENCE IS BAD!!"
+9 ;
VMSRPCT ;EP Calls ^AUPNPCT for "AQ" x-ref of .05 percentile field
+1 SET AUPNSAVX=X
SET X="AUPNPCT"
XECUTE ^%ZOSF("TEST")
SET X=AUPNSAVX
KILL AUPNSAVX
IF $TEST
DO ^AUPNPCT
+2 QUIT
+3 ;
EXIT ; COMMON ROUTINE EXIT
+1 KILL @AUPNCIXK
+2 QUIT
+3 ;
VMSR04X SET AUPNCIXV=$DATA(^AUPNVMSR("AQ",AUPNCIXT_$EXTRACT("000",1,3-$LENGTH($PIECE(X,".",1)))_X,DA))
IF AUPNCIXF="S"
SET ^(DA)=""
IF AUPNCIXF="K"
KILL ^(DA)
+1 QUIT
+2 ;
VMSR04B ; ENTRY POINT MAINTAINED FOR BACKWARD COMPATIBILITY
VMSR04BP SET AUPNCIX1="BPS"
SET AUPNCIX2="BPD"
GOTO VMSR04XX
VMSR04VU SET AUPNCIX1="VUR"
SET AUPNCIX2="VUL"
GOTO VMSR04XX
VMSR04VC SET AUPNCIX1="VCR"
SET AUPNCIX2="VCL"
VMSR04XX SET AUPNCIXV=$DATA(^AUPNVMSR("AQ",AUPNCIX1_$EXTRACT("000",1,3-$LENGTH(AUPNCIXX))_AUPNCIXX,DA))
IF AUPNCIXF="S"
SET ^(DA)=""
IF AUPNCIXF="K"
KILL ^(DA)
+1 SET AUPNCIXV=$DATA(^AUPNVMSR("AQ",AUPNCIX2_$EXTRACT("000",1,3-$LENGTH(AUPNCIXY))_AUPNCIXY,DA))
IF AUPNCIXF="S"
SET ^(DA)=""
IF AUPNCIXF="K"
KILL ^(DA)
+2 QUIT
+3 ;
VMSR01 ;EP V MEASUREMENT:MEASUREMENT (9000010.01,.01)
+1 SET AUPNCIXK="AUPNCIX1,AUPNCIX2,AUPNCIXA,AUPNCIXB,AUPNCIXK,AUPNCIXT,AUPNCIXX,AUPNCIXY,AUPNCIXZ,AUPNCIXV"
+2 IF $PIECE(^AUPNVMSR(DA,0),U,4)=""
GOTO EXIT
+3 SET AUPNCIXT=$PIECE(^AUTTMSR(X,0),U)
+4 SET AUPNCIXA="^BP^VC^VU^"
SET AUPNCIXB="^HC^HT^WT^"
SET AUPNCIXZ=U_AUPNCIXT_U
+5 IF (AUPNCIXA_AUPNCIXB)'[AUPNCIXZ
GOTO EXIT
+6 IF AUPNCIXB[AUPNCIXZ
DO VMSR01X
GOTO EXIT
+7 IF AUPNCIXA[AUPNCIXZ
SET AUPNCIXX=$PIECE($PIECE(^AUPNVMSR(DA,0),U,4),"/",1)
SET AUPNCIXY=$PIECE($PIECE(^AUPNVMSR(DA,0),U,4),"/",2)
DO @("VMSR01"_AUPNCIXT)
GOTO EXIT
+8 WRITE !!,"AUPNCIX:VMSR01 ERROR",!!,"NOTIFY YOUR SUPERVISOR IMMEDIATELY - CROSS REFERENCE IS BAD!!"
+9 GOTO EXIT
+10 ;
+11 ;
VMSR01X SET AUPNCIXV=$DATA(^AUPNVMSR("AQ",AUPNCIXT_$EXTRACT("000",1,3-$LENGTH($PIECE($PIECE(^AUPNVMSR(DA,0),U,4),".",1)))_$PIECE(^AUPNVMSR(DA,0),U,4),DA))
IF AUPNCIXF="S"
SET ^(DA)=""
IF AUPNCIXF="K"
KILL ^(DA)
+1 QUIT
+2 ;
VMSR01B ; ENTRY POINT MAINTAINED FOR BACKWARD COMPATIBILITY
VMSR01BP SET AUPNCIX1="BPS"
SET AUPNCIX2="BPD"
GOTO VMSR01XX
VMSR01VU SET AUPNCIX1="VUR"
SET AUPNCIX2="VUL"
GOTO VMSR01XX
VMSR01VC SET AUPNCIX1="VCR"
SET AUPNCIX2="VCL"
VMSR01XX SET AUPNCIXV=$DATA(^AUPNVMSR("AQ",AUPNCIX1_$EXTRACT("000",1,3-$LENGTH(AUPNCIXX))_AUPNCIXX,DA))
IF AUPNCIXF="S"
SET ^(DA)=""
IF AUPNCIXF="K"
KILL ^(DA)
+1 SET AUPNCIXV=$DATA(^AUPNVMSR("AQ",AUPNCIX2_$EXTRACT("000",1,3-$LENGTH(AUPNCIXY))_AUPNCIXY,DA))
IF AUPNCIXF="S"
SET ^(DA)=""
IF AUPNCIXF="K"
KILL ^(DA)
+2 QUIT
+3 ;
AUTO ; SETS V MEASUREMENT "AQ" XREF WITHOUT CALLING FILEMAN
+1 KILL ^AUPNVMSR("AQ")
+2 FOR DA=0:0
SET DA=$ORDER(^AUPNVMSR(DA))
IF 'DA
QUIT
SET AUPNCIXF="S"
SET AUPNCIXV=$GET(^(DA,0))
SET X=$PIECE(AUPNCIXV,U,4)
IF X'=""
DO VMSR04
WRITE "."
+3 QUIT
AUTO1 ;
+1 ;
+2 KILL ^AUPNVMSR("AQ")
+3 FOR DA=0:0
SET DA=$ORDER(^AUPNVMSR(DA))
IF 'DA
QUIT
SET AUPNCIXF="S"
SET AUPNCIXV=^(DA,0)
SET X=$PIECE(^AUPNVMSR(DA,0),U,1)
DO VMSR01
WRITE "."
+4 QUIT
+5 ;
VLAB04 ;EP - called from input transform on .04 of vlab
+1 ;if entry is made from PCC Data entry AND BLRENPUT routine exists
+2 ;then apply input tx check on result field
+3 ;IHS/TUCSON/LAB - added this sub routine to support lab 5.2 - patch 6 6/23/97
+4 ;postmaster - filegram
IF DUZ=.5
QUIT
+5 ;in lab 5.2
IF $DATA(BLRLINK)
QUIT
+6 ;not in direct data entry
IF '$DATA(APCDEIN)
QUIT
+7 ;override variable is set
IF $DATA(BLRCHKIP)
QUIT
+8 IF '$DATA(X)
QUIT
+9 IF X=""
QUIT
+10 NEW AUPNX
+11 SET AUPNX=X
SET X="BLRENPUT"
+12 XECUTE ^%ZOSF("TEST")
+13 SET X=AUPNX
+14 IF '$TEST
SET X=AUPNX
KILL AUPNX
QUIT
+15 KILL AUPNX
+16 DO ^BLRENPUT
+17 IF $DATA(X)
IF $LENGTH(X)>200!($LENGTH(X)<1)!($DATA(BLRKILL))
KILL X
+18 IF $DATA(BLRKILL)
DO EN^DDIOL($CHAR(7)_"Results can not be entered for this test!")
KILL BLRKILL
+19 QUIT
+20 ;
VXAMR(V,RETVAL) ;PEP - send back list of allowable result values
+1 IF $GET(V)=""
QUIT ""
+2 NEW C,Y,S
+3 KILL @RETVAL
+4 IF $EXTRACT(V)'?.N
SET V=$ORDER(^AUTTEXAM("B",V,0))
+5 IF 'V
QUIT ""
+6 SET C=$PIECE($GET(^AUTTEXAM(V,0)),U,2)
+7 IF C=""
QUIT ""
+8 SET S=0
+9 FOR Y="A","N","PR","PAP","PA","PO","L","M","H","RF","PS"
SET X=Y
DO VXAM04C
IF $DATA(X)
SET S=S+1
SET @RETVAL@(S)=X_U_$$EXTSET^XBFUNC(9000010.13,.04,X)
+10 QUIT C
+11 ;
VXAM04 ;EP - called from input tx on .04 field of V EXAM
+1 IF '$DATA(X)
QUIT
+2 IF '$GET(DA)
QUIT
+3 NEW C
SET C=$PIECE(^AUTTEXAM($PIECE(^AUPNVXAM(DA,0),U),0),U,2)
VXAM04C ;
+1 ;referral good for all exam types
IF X="RF"
QUIT
+2 IF X="PS"
IF (C'=38&(C'=39))
KILL X
QUIT
+3 IF C=38!(C=39)
IF X'="PS"
KILL X
QUIT
+4 IF X="PA"
IF C'=34
KILL X
QUIT
+5 IF X="PR"
IF C'=34
KILL X
QUIT
+6 IF X="PAP"
IF C'=34
KILL X
QUIT
+7 IF X="A"
IF C=34
KILL X
QUIT
+8 IF X="A"
IF C=35
KILL X
QUIT
+9 IF X="A"
IF C=36
KILL X
QUIT
+10 ;TAKE OUT 99
IF X="PO"
IF (C'=35&(C'=36)&(C'=99))
KILL X
QUIT
+11 IF X="L"
IF (C'=42&(C'=43))
KILL X
QUIT
+12 IF X="M"
IF (C'=42&(C'=43))
KILL X
QUIT
+13 IF X="H"
IF (C'=42&(C'=43))
KILL X
QUIT
+14 IF C=42!(C=43)
IF X'="L"
IF X'="M"
IF X'="H"
KILL X
QUIT
+15 QUIT
VXAM04H ;EP
+1 DO EN^DDIOL("RF (Referral Needed) is a valid choice for all exam types","","!")
+2 DO EN^DDIOL("N is a valid for all exam types, except VTE/Newborn Hearing/Suicide Assmt ","","!")
+3 ;D EN^DDIOL("and Suicide Assessment","","!")
+4 DO EN^DDIOL("PR, PAP, PA are only valid for Intimate Partner Violence exam type","","!")
+5 DO EN^DDIOL("A is not valid for Intimate Partner Violence/Alcohol Screening/Depression ","","!")
+6 DO EN^DDIOL("Screening/VTE Risk Assessment/Suicide Risk Assessment/Newborn Hearing exam types","","!")
+7 DO EN^DDIOL("PO is valid for Depression Screening and Alcohol Screening and BIMS exam types","","!")
+8 DO EN^DDIOL("L, M and H are only valid for VTE Risk Assessment/Suicide Risk Assessment exams","","!")
+9 DO EN^DDIOL("PS (Pass) is only valid for Newborn Hearing Right and Left","","!")
+10 QUIT
INPH ;EP - called from help 9000024
+1 DO EN^DDIOL("Must begin with a numeric value.")
+2 DO EN^DDIOL("Must contain a D for Days, W for Weeks, M for Months or Y for years.")
+3 DO EN^DDIOL("Examples: 2W for 2 weeks, 10M for 10 Months, 365D for 365 days, 2Y for 2 years.")
+4 QUIT
OUTTX(%) ;EP called from input transform
+1 IF $GET(%)=""
QUIT ""
+2 IF %["D"
QUIT +%_" Day"_$SELECT(+%>1:"s",1:"")
+3 IF %["M"
QUIT +%_" Month"_$SELECT(+%>1:"s",1:"")
+4 IF %["Y"
QUIT +%_" Year"_$SELECT(+%>1:"s",1:"")
+5 IF %["W"
QUIT +%_" Week"_$SELECT(+%>1:"s",1:"")
+6 QUIT %
INP ;EP - called from input transform 9000024
+1 IF $GET(X)=""
KILL X
QUIT
+2 IF '(+X)
DO EN^DDIOL("Must begin with a numeric value.")
KILL X
QUIT
+3 IF "MDYW"'[$EXTRACT(X,$LENGTH(X))
DO EN^DDIOL("Must contain a D for Days, W for Weeks, M for Months or Y for Years.")
KILL X
QUIT
+4 QUIT
CONVDAYS(V) ;EP
+1 NEW VAL
+2 IF V=""
QUIT ""
+3 IF V["D"
QUIT +V
+4 IF V["M"
SET VAL=+V*30.5
QUIT $PIECE(VAL,".")
+5 IF V["Y"
SET VAL=+V*365
QUIT $PIECE(VAL,".")
+6 IF V["W"
SET VAL=+V*7
QUIT $PIECE(VAL,".")
+7 QUIT ""
KGLB(V) ;EP
+1 IF V=""
QUIT ""
+2 NEW VAL
+3 SET VAL=V*2.2046226
+4 QUIT $PIECE(VAL,".")
KGOZ(V) ;EP
+1 IF V=""
QUIT ""
+2 NEW VAL
+3 SET VAL=V*2.2046226
+4 SET VAL="."_$PIECE(VAL,".",2)
+5 SET VAL=VAL*16
+6 QUIT $$STRIP^XLFSTR($JUSTIFY($PIECE(VAL,5,0)," "))
LBKG(V) ;EP
+1 IF V=""
QUIT ""
+2 NEW VAL
+3 SET VAL=V*.453592
+4 QUIT $$STRIP^XLFSTR(VAL," ")
OZ(V) ;EP
+1 NEW VAL
+2 IF V=""
QUIT ""
+3 SET VAL=$PIECE(V,".",2)
+4 IF VAL=""
QUIT 0
+5 SET VAL="."_VAL
+6 SET VAL=VAL*16
+7 SET VAL=$$STRIP^XLFSTR(VAL," ")
+8 QUIT VAL
CMPLDATE(%) ;EP - called from trigger on TREATMENT PLAN File
+1 IF $GET(%)=""
QUIT ""
+2 NEW A,B,C
+3 SET A=$PIECE(^AUPNTP(%,0),U,3)
+4 IF A=""
QUIT ""
+5 SET B=$PIECE(^AUPNTP(%,0),U,4)
+6 IF B=""
QUIT ""
+7 SET C=$$CONVDAYS(B)
+8 QUIT $$FMADD^XLFDT(A,C)
ICD(Y,N,D) ;EP - called from input transforms
+1 SET N=$GET(N)
+2 SET D=$GET(D)
+3 IF $$CHK(Y,N,D)
+4 IF $DATA(^ICD9(Y))
QUIT
+5 QUIT
CHK(Y,N,D) ; SCREEN OUT E CODES AND INACTIVE CODES
+1 IF $DATA(DIFGLINE)
QUIT 1
+2 NEW %,A,I,V
+3 IF $GET(D)
GOTO CHK1
+4 IF $GET(N)
SET D=$PIECE($PIECE(^AUPNTP(N,0),U,2),".")
+5 IF D=""
SET D=DT
CHK1 ;
+1 SET I=$$IMP^AUPNSICD(D)
+2 SET %=$$ICDDX^ICDEX(Y,D,,"I")
+3 ;not correct coding system
IF $PIECE(%,U,20)'=I
QUIT 0
+4 SET I="CHKDX"_I
+5 GOTO @I
+6 ;Q
CHKDX1 ;CODING SYSTEM 1 - ICD9
+1 ;no E codes
IF $EXTRACT($PIECE(%,U,2),1)="E"
QUIT 0
+2 ;STATUS IS INACTIVE
IF $$VERSION^XPDUTL("BCSV")]""
IF '$PIECE(%,U,10)
QUIT 0
+3 IF $$VERSION^XPDUTL("BCSV")]""
GOTO CSEX
+4 SET A=$PIECE($GET(^ICD9(Y,9999999)),U,4)
SET I=$PIECE(^ICD9(Y,0),U,11)
+5 IF D]""
IF I]""
IF D>I
QUIT 0
+6 IF D]""
IF A]""
IF D<A
QUIT 0
+7 ;
CSEX ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
+1 IF '$DATA(AUPNSEX)
QUIT 1
+2 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
QUIT 0
+3 QUIT 1
+4 ;
CHKDX30 ;coding system 30 - ICD10
+1 ;no codes V00-Y99 per Leslie Racine.
IF $EXTRACT($PIECE(%,U,2),1)="V"
QUIT 0
+2 IF $EXTRACT($PIECE(%,U,2),1)="W"
QUIT 0
+3 IF $EXTRACT($PIECE(%,U,2),1)="X"
QUIT 0
+4 IF $EXTRACT($PIECE(%,U,2),1)="Y"
QUIT 0
+5 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+6 ;
CSEX30 ; IF 'USE WITH SEX' FIELD HAS A VALUE CHECK THAT VALUE AGAINST AUPNSEX
+1 IF '$DATA(AUPNSEX)
QUIT 1
+2 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
QUIT 0
+3 QUIT 1
WT ;EP (WEIGHT)
+1 IF X?.E.A.E
DO MWT
+2 IF '$DATA(X)
QUIT
+3 DO WTC
+4 ;S:$P(X,".",2)?1N.N X=X+.00005,X=$P(X,".",1)_"."_$E($P(X,".",2),1,4)
+5 SET X=+X
+6 IF '$DATA(X)
QUIT
+7 IF +X'=X!(X>1000)
KILL X
+8 IF '$DATA(X)
QUIT
+9 ;K:X-(X\1)#.0625 X
+10 QUIT
WTC IF +X=X!(X'[" ")
QUIT
+1 IF '(X?1.3N1" "1.2N!(X?1.3N1" "1.2N1"/"1.2N))
QUIT
+2 IF X'["/"
IF +$PIECE(X," ",2)>16
QUIT
SET X=+X+(+$PIECE(X," ",2)/16)
QUIT
+3 IF +$PIECE($PIECE(X," ",2),"/",1)'<+$PIECE($PIECE(X," ",2),"/",2)
QUIT
+4 SET X=+X+((+$PIECE(X," ",2)/$PIECE($PIECE(X," ",2),"/",2)))
+5 QUIT
+6 ;
MWT ;
+1 NEW AUPNC,AUPNI,AUPNJ
+2 SET AUPNJ=$LENGTH(X)
FOR AUPNI=1:1:AUPNJ
SET AUPNC=$EXTRACT(X,AUPNI)
IF AUPNC?1A
SET AUPNC=$SELECT(AUPNC?1L:$CHAR($ASCII(AUPNC)-32),1:AUPNC)
+3 SET (AUPNI,AUPNC)=""
FOR AUPNI=1:1:AUPNJ
SET AUPNC=$EXTRACT(X,AUPNI)
IF "GK"[AUPNC
QUIT
+4 IF "GK"[AUPNC
DO @AUPNC
+5 KILL AUPNC,AUPNI,AUPNJ
+6 QUIT
MWTC ;
+1 IF +X=X!(X'[" ")!(X'["/")
QUIT
+2 IF '(X?1.6N1" "1.2N1"/"1.2N)
KILL X
+3 IF '$DATA(X)
QUIT
+4 SET X=+X+((+$PIECE(X," ",2)/$PIECE($PIECE(X," ",2),"/",2)))
+5 QUIT
K ;
+1 IF X["/"
SET X=$PIECE(X,AUPNC,1)
DO MWTC
+2 IF '$DATA(X)
QUIT
+3 SET X=+X
+4 SET X=(X*2.2046226)
+5 QUIT
G ;
+1 IF X["/"
SET X=$PIECE(X,AUPNC,1)
DO MWTC
+2 IF '$DATA(X)
QUIT
+3 SET X=+X
+4 SET X=(X*.0022046226)
+5 QUIT
C ;
+1 IF X["/"
SET X=$PIECE(X,AUPNC,1)
DO MWTC
+2 IF '$DATA(X)
QUIT
+3 SET X=+X
+4 SET X=(X*.393701)
+5 QUIT
+6 ;
V4906 ;EP - help
+1 DO EN^DDIOL("Select whether the patient has any high risk weight issues.")
+2 DO EN^DDIOL("For adults, this might be: <80% IBW; 1 week > 2% weight change;")
+3 DO EN^DDIOL("1 month > 5% weight change; 3 months > 7.5% weight change;")
+4 DO EN^DDIOL("6 months > 10% weight change. For pediatrics, this might ")
+5 DO EN^DDIOL("be: < 80% IBW; Wt < 5%ile; L < 5%ile; Wt/L < 5%ile.")
+6 QUIT
V4907 ;EP - help
+1 DO EN^DDIOL("Select whether the patient has any high risk diagnoses; ")
+2 DO EN^DDIOL("for example: acute renal failure; AIDS; bone marrow transplant; ")
+3 DO EN^DDIOL("new-onset diabetes; pancreatitis; sepsis; congenital heart ")
+4 DO EN^DDIOL("disease; failure to thrive; high risk pregnancy.")
+5 QUIT
NY(%) ;EP - called from computed field
+1 IF $GET(%)=""
QUIT ""
+2 IF '$DATA(^AUPNVNTS(%,0))
QUIT ""
+3 NEW T,A
+4 SET T=0
+5 FOR A=4:1:12
SET T=T+$PIECE(^AUPNVNTS(%,0),U,A)
+6 QUIT T
DURENDDT(%) ;EP - called from trigger on V ANTI-COAG File
+1 IF $GET(%)=""
QUIT ""
+2 NEW A,B,C
+3 SET A=$PIECE(^AUPNVACG(%,0),U,7)
+4 IF A=""
QUIT ""
+5 SET B=$PIECE(^AUPNVACG(%,0),U,8)
+6 IF B=""
QUIT ""
+7 SET C=$$CONVDUR(A)
+8 IF C=""
QUIT ""
+9 QUIT $$FMADD^XLFDT(B,C)
CONVDUR(B) ;
+1 IF B=1
QUIT 90
+2 IF B=2
QUIT 180
+3 IF B=3
QUIT 365
+4 QUIT ""
