APCDHIST ; IHS/CMI/LAB - DISPLAY HIST. DATA ;
;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
;
DATE S APCDTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+$E(Y,1,3))" K Y
Q
FMH ; ******************** FAMILY HISTORY * 9000014 *******
D DATE
S APCDTICF="S"
; <SETUP>
I '$D(^AUPNFH("AC",APCDPAT)) W !!,"******************* NO FAMILY HISTORY ON FILE **********************" Q
W !!,"****************** FAMILY HISTORY ******************",!!
; <DISPLAY>
S APCDTDFN="" F APCDTQ=0:0 S APCDTDFN=$O(^AUPNFH("AC",APCDPAT,APCDTDFN)) Q:APCDTDFN="" D FHDSP
; <CLEANUP>
FMHX K APCDTDFN,APCDTN,APCDTICD,APCDTDAT,APCDTNRQ,APCDTICL,APCDTNQ,APCDTICF,APCDTCVD,APCDTQ,Y
Q
FHDSP S APCDTN=^AUPNFH(APCDTDFN,0)
S APCDTICD=$P(APCDTN,U) D GETICDDX
S Y=$P(APCDTN,U,3) X APCDTCVD S APCDTDAT=Y
S APCDTNRQ=$$VAL^XBDIQ1(9000014,APCDTDFN,.04)
D GETNARR
W APCDTDAT S APCDTICL=12
NEW X,R,S,A,P
S (X,R,S,N,A,P)=""
S R=$$VAL^XBDIQ1(9000014,APCDTDFN,.07)
S N=$$VAL^XBDIQ1(9000014,APCDTDFN,.04)_" ("_$$VAL^XBDIQ1(9000014,APCDTDFN,.01)_")"
S A=$P(^AUPNFH(APCDTDFN,0),U,5)
S S=$$VAL^XBDIQ1(9000014,APCDTDFN,.06)
S P=$$VAL^XBDIQ1(9000014,APCDTDFN,.08)
S X=R
I X]"" S X=X_"; "
S X=X_N
S X=X_$S(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")
S X=X_$S(S]"":"; Status: "_S,1:"; Status: None")
S X=X_$S(P]"":"; Documented By: "_P,1:"")
S APCDTICL=12,APCDTNRQ=X,APCDTICD=""
D PRTICD
Q
;
PMH ; ******************** PERSONAL HISTORY * 9000013 *******
; <SETUP>
D DATE
S APCDTICF="S"
; <SETUP>
I '$D(^AUPNPH("AC",APCDPAT)) W !!,"******************* NO PERSONAL HISTORY ON FILE **********************" Q
; <DISPLAY>
W !!,"********************** PERSONAL HISTORY ********************",!!
S APCDTDFN="" F APCDTQ=0:0 S APCDTDFN=$O(^AUPNPH("AC",APCDPAT,APCDTDFN)) Q:APCDTDFN="" D PHDSP
; <CLEANUP>
PMHX K APCDTDFN,APCDTN,APCDTICD,APCDTICL,APCDTNRQ,APCDTDAT,APCDTDTH,APCDTICF,APCDTQ,APCDTCVD,Y
Q
PHDSP S APCDTN=^AUPNPH(APCDTDFN,0)
S APCDTICD=$P(APCDTN,U) D GETICDDX
S Y=$P(APCDTN,U,3) X APCDTCVD S APCDTDAT=Y
S APCDTDTH=$P(APCDTN,U,5) I APCDTDTH]"" S Y=APCDTDTH X APCDTCVD S APCDTDTH=Y
S APCDTNRQ=$P(APCDTN,U,4)
D GETNARR
I APCDTDTH]"" S:APCDTNRQ]"" APCDTNRQ=APCDTNRQ_" " S APCDTNRQ=APCDTNRQ_"(onset "_APCDTDTH_")"
W APCDTDAT,?12,$$VAL^XBDIQ1(9000013,APCDTDFN,.01) S APCDTICL=22 D PRTICD
Q
;
GETICDDX ;
S:APCDTICF="S" APCDTICD=$P($$ICDDX^ICDEX(APCDTICD,$P(APCDTN,U,3)),U,4)
Q
GETICDOP ;
S:APCDTICF="S" APCDTICD=$P($$ICDOP^ICDEX(APCDTICD,$P(APCDTN,U,3),,"I"),U,5)
Q
;
PRTICD ;
S:APCDTNRQ="" APCDTNRQ="<no narrative provided>" S APCDTICD=""
S APCDTTXT=APCDTICD D PRTTXT
Q
;
PRTTXT ; GENERALIZED TEXT PRINTER
S APCDTDLT=1,APCDTILN=80-APCDTICL-1
F APCDTQ=0:0 S:APCDTNRQ]""&(($L(APCDTNRQ)+$L(APCDTTXT)+2)<255) APCDTTXT=$S(APCDTTXT]"":APCDTTXT_"; ",1:"")_APCDTNRQ,APCDTNRQ="" Q:APCDTTXT="" D PRTTXT2
K APCDTILN,APCDTDLT,APCDTF,APCDTC,APCDTTXT
Q
PRTTXT2 D GETFRAG W ?APCDTICL W APCDTF,! S APCDTICL=APCDTICL+APCDTDLT,APCDTILN=APCDTILN-APCDTDLT,APCDTDLT=0
Q
GETFRAG I $L(APCDTTXT)<APCDTILN S APCDTF=APCDTTXT,APCDTTXT="" Q
F APCDTC=APCDTILN:-1:1 Q:$E(APCDTTXT,APCDTC)=" "
S APCDTF=$E(APCDTTXT,1,APCDTC-1),APCDTTXT=$E(APCDTTXT,APCDTC+1,255)
Q
;
GETNARR ;
;I APCDTNRQ]"" S APCDTNRQ=$S($D(^AUTNPOV(APCDTNRQ)):$P(^AUTNPOV(APCDTNRQ,0),U),1:"***** "_APCDTNRQ_" *****")
;E S APCDTNRQ=""
Q
;
GETSITEV ;
S %=^AUPNVSIT(APCDTVDF,0),APCDTVSC=$P(%,U,7),APCDTITE=$P(%,U,6)
GETSITE ;
S:APCDTITE="" APCDTITE="null"
S %=$G(^AUTTLOC(APCDTITE,0))
S APCDTNFL=$P(%,U),APCDTNFL=$S($D(^DIC(4,APCDTITE,0)):$P(^(0),U),1:"<"_APCDTITE_">")
S APCDTNSH=$P(%,U,2) I APCDTNSH="" S APCDTNSH="<"_APCDTITE_">"
S APCDTNAB=$J($P(%,U,7),4) I APCDTNAB="" S APCDTNAB="<"_APCDTITE_">"
Q
REF ;EP - called from [APCD REF] template to
;display currently documented refusals
Q:'$D(^AUPNPREF("AC",APCDPAT))
K APCDREF
NEW APCDX,A,B,C,D S APCDX=0 F S APCDX=$O(^AUPNPREF("AC",APCDPAT,APCDX)) Q:APCDX'=+APCDX D
.S A=$P(^AUPNPREF(APCDX,0),U),B=$P(^AUPNPREF(APCDX,0),U,4),D=$P(^AUPNPREF(APCDX,0),U,3)
.Q:B=""
.Q:A=""
.Q:D=""
.S D=9999999-D,APCDREF(A,B,9999999-D)=APCDX
.Q
W !!,"Last of each service type documented in PCC for "_$P(^DPT(APCDPAT,0),U)_":",!
S A="" F S A=$O(APCDREF(A)) Q:A'=+A S B="" F S B=$O(APCDREF(A,B)) Q:B="" D
.S D=$O(APCDREF(A,B,0))
.S APCDX=APCDREF(A,B,D)
.W !?2,$E($$VAL^XBDIQ1(9000022,APCDX,.01),1,15),?19,$$VAL^XBDIQ1(9000022,APCDX,.04),?62,$$VAL^XBDIQ1(9000022,APCDX,.03)
.W !?5,"Service Type: ",$$VAL^XBDIQ1(9000022,APCDX,.07)
.Q
W !
Q
IMMCPT ;EP - called from APCD CPT templates
NEW X
; S X=$P(^ICPT(APCDCPTP,0),U)
S X=$P($$CPT^ICPTCOD(APCDCPTP),U,2)
I +X<90471 Q
I +X>90749 Q
W !!,"REMINDER: You have entered a CPT code for an immunization. Please check the",!,"immunizations listed below and make sure the immunization has been entered using",!,"the IM mnemonic as well as with the CPT mnemonic."
I '$O(^AUPNVIMM("AD",APCDVSIT,0)) W !,"There are no immunizations entered via the IM mnemonic.",! Q
NEW Y S X=0 F S X=$O(^AUPNVIMM("AD",APCDVSIT,X)) Q:X'=+X D
.W !?5,$P(^AUTTIMM($P(^AUPNVIMM(X,0),U),0),U),?40,"code: ",$P(^AUTTIMM($P(^AUPNVIMM(X,0),U),0),U,3)
.Q
W !
Q
APCDHIST ; IHS/CMI/LAB - DISPLAY HIST. DATA ;
+1 ;;2.0;IHS PCC SUITE;**7,11**;MAY 14, 2009;Build 58
+2 ;
DATE SET APCDTCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$E(Y,6,7)_""/""_(1700+$E(Y,1,3))"
KILL Y
+1 QUIT
FMH ; ******************** FAMILY HISTORY * 9000014 *******
+1 DO DATE
+2 SET APCDTICF="S"
+3 ; <SETUP>
+4 IF '$DATA(^AUPNFH("AC",APCDPAT))
WRITE !!,"******************* NO FAMILY HISTORY ON FILE **********************"
QUIT
+5 WRITE !!,"****************** FAMILY HISTORY ******************",!!
+6 ; <DISPLAY>
+7 SET APCDTDFN=""
FOR APCDTQ=0:0
SET APCDTDFN=$ORDER(^AUPNFH("AC",APCDPAT,APCDTDFN))
IF APCDTDFN=""
QUIT
DO FHDSP
+8 ; <CLEANUP>
FMHX KILL APCDTDFN,APCDTN,APCDTICD,APCDTDAT,APCDTNRQ,APCDTICL,APCDTNQ,APCDTICF,APCDTCVD,APCDTQ,Y
+1 QUIT
FHDSP SET APCDTN=^AUPNFH(APCDTDFN,0)
+1 SET APCDTICD=$PIECE(APCDTN,U)
DO GETICDDX
+2 SET Y=$PIECE(APCDTN,U,3)
XECUTE APCDTCVD
SET APCDTDAT=Y
+3 SET APCDTNRQ=$$VAL^XBDIQ1(9000014,APCDTDFN,.04)
+4 DO GETNARR
+5 WRITE APCDTDAT
SET APCDTICL=12
+6 NEW X,R,S,A,P
+7 SET (X,R,S,N,A,P)=""
+8 SET R=$$VAL^XBDIQ1(9000014,APCDTDFN,.07)
+9 SET N=$$VAL^XBDIQ1(9000014,APCDTDFN,.04)_" ("_$$VAL^XBDIQ1(9000014,APCDTDFN,.01)_")"
+10 SET A=$PIECE(^AUPNFH(APCDTDFN,0),U,5)
+11 SET S=$$VAL^XBDIQ1(9000014,APCDTDFN,.06)
+12 SET P=$$VAL^XBDIQ1(9000014,APCDTDFN,.08)
+13 SET X=R
+14 IF X]""
SET X=X_"; "
+15 SET X=X_N
+16 SET X=X_$SELECT(A]"":"; Age at Onset: "_A,1:"; Age at Onset: None")
+17 SET X=X_$SELECT(S]"":"; Status: "_S,1:"; Status: None")
+18 SET X=X_$SELECT(P]"":"; Documented By: "_P,1:"")
+19 SET APCDTICL=12
SET APCDTNRQ=X
SET APCDTICD=""
+20 DO PRTICD
+21 QUIT
+22 ;
PMH ; ******************** PERSONAL HISTORY * 9000013 *******
+1 ; <SETUP>
+2 DO DATE
+3 SET APCDTICF="S"
+4 ; <SETUP>
+5 IF '$DATA(^AUPNPH("AC",APCDPAT))
WRITE !!,"******************* NO PERSONAL HISTORY ON FILE **********************"
QUIT
+6 ; <DISPLAY>
+7 WRITE !!,"********************** PERSONAL HISTORY ********************",!!
+8 SET APCDTDFN=""
FOR APCDTQ=0:0
SET APCDTDFN=$ORDER(^AUPNPH("AC",APCDPAT,APCDTDFN))
IF APCDTDFN=""
QUIT
DO PHDSP
+9 ; <CLEANUP>
PMHX KILL APCDTDFN,APCDTN,APCDTICD,APCDTICL,APCDTNRQ,APCDTDAT,APCDTDTH,APCDTICF,APCDTQ,APCDTCVD,Y
+1 QUIT
PHDSP SET APCDTN=^AUPNPH(APCDTDFN,0)
+1 SET APCDTICD=$PIECE(APCDTN,U)
DO GETICDDX
+2 SET Y=$PIECE(APCDTN,U,3)
XECUTE APCDTCVD
SET APCDTDAT=Y
+3 SET APCDTDTH=$PIECE(APCDTN,U,5)
IF APCDTDTH]""
SET Y=APCDTDTH
XECUTE APCDTCVD
SET APCDTDTH=Y
+4 SET APCDTNRQ=$PIECE(APCDTN,U,4)
+5 DO GETNARR
+6 IF APCDTDTH]""
IF APCDTNRQ]""
SET APCDTNRQ=APCDTNRQ_" "
SET APCDTNRQ=APCDTNRQ_"(onset "_APCDTDTH_")"
+7 WRITE APCDTDAT,?12,$$VAL^XBDIQ1(9000013,APCDTDFN,.01)
SET APCDTICL=22
DO PRTICD
+8 QUIT
+9 ;
GETICDDX ;
+1 IF APCDTICF="S"
SET APCDTICD=$PIECE($$ICDDX^ICDEX(APCDTICD,$PIECE(APCDTN,U,3)),U,4)
+2 QUIT
GETICDOP ;
+1 IF APCDTICF="S"
SET APCDTICD=$PIECE($$ICDOP^ICDEX(APCDTICD,$PIECE(APCDTN,U,3),,"I"),U,5)
+2 QUIT
+3 ;
PRTICD ;
+1 IF APCDTNRQ=""
SET APCDTNRQ="<no narrative provided>"
SET APCDTICD=""
+2 SET APCDTTXT=APCDTICD
DO PRTTXT
+3 QUIT
+4 ;
PRTTXT ; GENERALIZED TEXT PRINTER
+1 SET APCDTDLT=1
SET APCDTILN=80-APCDTICL-1
+2 FOR APCDTQ=0:0
IF APCDTNRQ]""&(($LENGTH(APCDTNRQ)+$LENGTH(APCDTTXT)+2)<255)
SET APCDTTXT=$SELECT(APCDTTXT]"":APCDTTXT_"; ",1:"")_APCDTNRQ
SET APCDTNRQ=""
IF APCDTTXT=""
QUIT
DO PRTTXT2
+3 KILL APCDTILN,APCDTDLT,APCDTF,APCDTC,APCDTTXT
+4 QUIT
PRTTXT2 DO GETFRAG
WRITE ?APCDTICL
WRITE APCDTF,!
SET APCDTICL=APCDTICL+APCDTDLT
SET APCDTILN=APCDTILN-APCDTDLT
SET APCDTDLT=0
+1 QUIT
GETFRAG IF $LENGTH(APCDTTXT)<APCDTILN
SET APCDTF=APCDTTXT
SET APCDTTXT=""
QUIT
+1 FOR APCDTC=APCDTILN:-1:1
IF $EXTRACT(APCDTTXT,APCDTC)=" "
QUIT
+2 SET APCDTF=$EXTRACT(APCDTTXT,1,APCDTC-1)
SET APCDTTXT=$EXTRACT(APCDTTXT,APCDTC+1,255)
+3 QUIT
+4 ;
GETNARR ;
+1 ;I APCDTNRQ]"" S APCDTNRQ=$S($D(^AUTNPOV(APCDTNRQ)):$P(^AUTNPOV(APCDTNRQ,0),U),1:"***** "_APCDTNRQ_" *****")
+2 ;E S APCDTNRQ=""
+3 QUIT
+4 ;
GETSITEV ;
+1 SET %=^AUPNVSIT(APCDTVDF,0)
SET APCDTVSC=$PIECE(%,U,7)
SET APCDTITE=$PIECE(%,U,6)
GETSITE ;
+1 IF APCDTITE=""
SET APCDTITE="null"
+2 SET %=$GET(^AUTTLOC(APCDTITE,0))
+3 SET APCDTNFL=$PIECE(%,U)
SET APCDTNFL=$SELECT($DATA(^DIC(4,APCDTITE,0)):$PIECE(^(0),U),1:"<"_APCDTITE_">")
+4 SET APCDTNSH=$PIECE(%,U,2)
IF APCDTNSH=""
SET APCDTNSH="<"_APCDTITE_">"
+5 SET APCDTNAB=$JUSTIFY($PIECE(%,U,7),4)
IF APCDTNAB=""
SET APCDTNAB="<"_APCDTITE_">"
+6 QUIT
REF ;EP - called from [APCD REF] template to
+1 ;display currently documented refusals
+2 IF '$DATA(^AUPNPREF("AC",APCDPAT))
QUIT
+3 KILL APCDREF
+4 NEW APCDX,A,B,C,D
SET APCDX=0
FOR
SET APCDX=$ORDER(^AUPNPREF("AC",APCDPAT,APCDX))
IF APCDX'=+APCDX
QUIT
Begin DoDot:1
+5 SET A=$PIECE(^AUPNPREF(APCDX,0),U)
SET B=$PIECE(^AUPNPREF(APCDX,0),U,4)
SET D=$PIECE(^AUPNPREF(APCDX,0),U,3)
+6 IF B=""
QUIT
+7 IF A=""
QUIT
+8 IF D=""
QUIT
+9 SET D=9999999-D
SET APCDREF(A,B,9999999-D)=APCDX
+10 QUIT
End DoDot:1
+11 WRITE !!,"Last of each service type documented in PCC for "_$PIECE(^DPT(APCDPAT,0),U)_":",!
+12 SET A=""
FOR
SET A=$ORDER(APCDREF(A))
IF A'=+A
QUIT
SET B=""
FOR
SET B=$ORDER(APCDREF(A,B))
IF B=""
QUIT
Begin DoDot:1
+13 SET D=$ORDER(APCDREF(A,B,0))
+14 SET APCDX=APCDREF(A,B,D)
+15 WRITE !?2,$EXTRACT($$VAL^XBDIQ1(9000022,APCDX,.01),1,15),?19,$$VAL^XBDIQ1(9000022,APCDX,.04),?62,$$VAL^XBDIQ1(9000022,APCDX,.03)
+16 WRITE !?5,"Service Type: ",$$VAL^XBDIQ1(9000022,APCDX,.07)
+17 QUIT
End DoDot:1
+18 WRITE !
+19 QUIT
IMMCPT ;EP - called from APCD CPT templates
+1 NEW X
+2 ; S X=$P(^ICPT(APCDCPTP,0),U)
+3 SET X=$PIECE($$CPT^ICPTCOD(APCDCPTP),U,2)
+4 IF +X<90471
QUIT
+5 IF +X>90749
QUIT
+6 WRITE !!,"REMINDER: You have entered a CPT code for an immunization. Please check the",!,"immunizations listed below and make sure the immunization has been entered using",!,"the IM mnemonic as well as with the CPT mnemonic."
+7 IF '$ORDER(^AUPNVIMM("AD",APCDVSIT,0))
WRITE !,"There are no immunizations entered via the IM mnemonic.",!
QUIT
+8 NEW Y
SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AD",APCDVSIT,X))
IF X'=+X
QUIT
Begin DoDot:1
+9 WRITE !?5,$PIECE(^AUTTIMM($PIECE(^AUPNVIMM(X,0),U),0),U),?40,"code: ",$PIECE(^AUTTIMM($PIECE(^AUPNVIMM(X,0),U),0),U,3)
+10 QUIT
End DoDot:1
+11 WRITE !
+12 QUIT
