APCDEGP3 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
POV ;EP
I $Y>(IOSL-5) D FF Q:APCDQUIT
W !,$TR($J("",80)," ","_")
W !?3,"ICD CODE PURPOSE OF VISIT (POV)"
W !,$TR($J("",80)," ","_")
POV1 ;
S (APCDX,APCDC)=0 F S APCDX=$O(^AUPNVPOV("AD",APCDR,APCDX)) Q:APCDX'=+APCDX!(APCDQUIT) D
.I $Y>(IOSL-3) D FF Q:APCDQUIT
.W !?5,$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCDX,0),U)),U,2)
.;S APCDTNRQ=$P(^ICD9($P(^AUPNVPOV(APCDX,0),U),0),U,2),APCDTICL=18,APCDTTXT="" D PRTTXT
.S APCDTNRQ=$$VAL^XBDIQ1(9000010.07,APCDX,.04) S APCDTNRQ=$S(APCDTNRQ]"":APCDTNRQ,1:"<<none>>"),APCDTICL=18,APCDTTXT="" D PRTTXT
.S APCDC=APCDC+2
.Q
F I=APCDC:1:3 D:$Y>(IOSL-3) FF Q:APCDQUIT W !
D:$Y>(IOSL-3) FF Q:APCDQUIT W !,$TR($J("",80)," ","_")
MEDS ;
I '$D(^AUPNVMED("AD",APCDR)) W !! G TRT
I $Y>(IOSL-5) D FF Q:APCDQUIT
W !?3,"MEDICATIONS: "
S (C,X)=0 F S X=$O(^AUPNVMED("AD",APCDR,X)) Q:X'=+X S Y=+^AUPNVMED(X,0) D
. W:C ! W ?16,$P(^PSDRUG(Y,0),U)
. W ?48,"QUANTITY: ",$P(^AUPNVMED(X,0),U,6)," DAYS: ",$P(^(0),U,7)
. W !?17,"SIG: ",$P(^AUPNVMED(X,0),U,5)
. S C=C+1 Q
TRT ;
I '$D(^AUPNVTRT("AD",APCDR)) W !! G PTED
I $Y>(IOSL-5) D FF Q:APCDQUIT
W !,$TR($J("",80)," ","_")
W !?3,"TREATMENTS PROVIDED: "
S (C,X)=0 F S X=$O(^AUPNVTRT("AD",APCDR,X)) Q:X'=+X S Y=+^AUPNVTRT(X,0) D
. W:C ! W ?26,$P(^AUTTTRT(Y,0),U)
. S C=C+1 Q
PTED ;
I '$D(^AUPNVPED("AD",APCDR)) W !! G DEMO
I $Y>(IOSL-5) D FF Q:APCDQUIT
W !,$TR($J("",80)," ","_")
W !?3,"PATIENT EDUCATION PROVIDED: "
S (C,X)=0 F S X=$O(^AUPNVPED("AD",APCDR,X)) Q:X'=+X S Y=+^AUPNVPED(X,0) D
. W:C ! W ?32,$P(^AUTTEDT(Y,0),U)
. S C=C+1 Q
DEMO ;demographics
I $Y>(IOSL-9) D FF Q:APCDQUIT
S DFN=$P(APCDR0,U,5)
S APCDHRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
S:APCDHRN="" APCDHRN="<?????>"
W !,$TR($J("",80)," ","_")
W !?3,"HR#: ",APCDHRN,?30,"SSN: ",$P(^DPT(DFN,0),U,9)
W !,?3,"NAME:",?9,$P(^DPT(DFN,0),U)
W !?3,"SEX: ",?9,$$EXTSET^XBFUNC(2,.02,$P(^DPT(DFN,0),U,2)),?30,"TRIBE: " I $P(^AUPNPAT(DFN,11),U,8)]"" W $P(^AUTTTRI($P(^AUPNPAT(DFN,11),U,8),0),U)
W !?3,"DOB: " S Y=$P(^DPT(DFN,0),U,3) I Y]"" D DD^%DT W ?9,Y
W !?3,"RESIDENCE: ",$P($G(^AUPNPAT(DFN,11)),U,18)
W !?3,"FACILITY: ",$E($P(^DIC(4,DUZ(2),0),U),1,25),?38,"LOCATION: ",$P(^DIC(4,$P(APCDR0,U,6),0),U)
I $P($G(^AUPNVSIT(APCDR,21)),U)]"" W !?3,"OUTSIDE LOCATION: ",$P(^AUPNVSIT(APCDR,21),U)
W !!?20,"PROVIDER SIGNATURE: "
W !!
W !,$TR($J("",80)," ","*")
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,APCDTDOO
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
;
FF ;
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCDQUIT=1 Q
W:$D(IOF) @IOF
Q
Q
APCDEGP3 ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
POV ;EP
+1 IF $Y>(IOSL-5)
DO FF
IF APCDQUIT
QUIT
+2 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+3 WRITE !?3,"ICD CODE PURPOSE OF VISIT (POV)"
+4 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
POV1 ;
+1 SET (APCDX,APCDC)=0
FOR
SET APCDX=$ORDER(^AUPNVPOV("AD",APCDR,APCDX))
IF APCDX'=+APCDX!(APCDQUIT)
QUIT
Begin DoDot:1
+2 IF $Y>(IOSL-3)
DO FF
IF APCDQUIT
QUIT
+3 WRITE !?5,$PIECE($$ICDDX^ICDEX($PIECE(^AUPNVPOV(APCDX,0),U)),U,2)
+4 ;S APCDTNRQ=$P(^ICD9($P(^AUPNVPOV(APCDX,0),U),0),U,2),APCDTICL=18,APCDTTXT="" D PRTTXT
+5 SET APCDTNRQ=$$VAL^XBDIQ1(9000010.07,APCDX,.04)
SET APCDTNRQ=$SELECT(APCDTNRQ]"":APCDTNRQ,1:"<<none>>")
SET APCDTICL=18
SET APCDTTXT=""
DO PRTTXT
+6 SET APCDC=APCDC+2
+7 QUIT
End DoDot:1
+8 FOR I=APCDC:1:3
IF $Y>(IOSL-3)
DO FF
IF APCDQUIT
QUIT
WRITE !
+9 IF $Y>(IOSL-3)
DO FF
IF APCDQUIT
QUIT
WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
MEDS ;
+1 IF '$DATA(^AUPNVMED("AD",APCDR))
WRITE !!
GOTO TRT
+2 IF $Y>(IOSL-5)
DO FF
IF APCDQUIT
QUIT
+3 WRITE !?3,"MEDICATIONS: "
+4 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVMED("AD",APCDR,X))
IF X'=+X
QUIT
SET Y=+^AUPNVMED(X,0)
Begin DoDot:1
+5 IF C
WRITE !
WRITE ?16,$PIECE(^PSDRUG(Y,0),U)
+6 WRITE ?48,"QUANTITY: ",$PIECE(^AUPNVMED(X,0),U,6)," DAYS: ",$PIECE(^(0),U,7)
+7 WRITE !?17,"SIG: ",$PIECE(^AUPNVMED(X,0),U,5)
+8 SET C=C+1
QUIT
End DoDot:1
TRT ;
+1 IF '$DATA(^AUPNVTRT("AD",APCDR))
WRITE !!
GOTO PTED
+2 IF $Y>(IOSL-5)
DO FF
IF APCDQUIT
QUIT
+3 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+4 WRITE !?3,"TREATMENTS PROVIDED: "
+5 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVTRT("AD",APCDR,X))
IF X'=+X
QUIT
SET Y=+^AUPNVTRT(X,0)
Begin DoDot:1
+6 IF C
WRITE !
WRITE ?26,$PIECE(^AUTTTRT(Y,0),U)
+7 SET C=C+1
QUIT
End DoDot:1
PTED ;
+1 IF '$DATA(^AUPNVPED("AD",APCDR))
WRITE !!
GOTO DEMO
+2 IF $Y>(IOSL-5)
DO FF
IF APCDQUIT
QUIT
+3 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+4 WRITE !?3,"PATIENT EDUCATION PROVIDED: "
+5 SET (C,X)=0
FOR
SET X=$ORDER(^AUPNVPED("AD",APCDR,X))
IF X'=+X
QUIT
SET Y=+^AUPNVPED(X,0)
Begin DoDot:1
+6 IF C
WRITE !
WRITE ?32,$PIECE(^AUTTEDT(Y,0),U)
+7 SET C=C+1
QUIT
End DoDot:1
DEMO ;demographics
+1 IF $Y>(IOSL-9)
DO FF
IF APCDQUIT
QUIT
+2 SET DFN=$PIECE(APCDR0,U,5)
+3 SET APCDHRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+4 IF APCDHRN=""
SET APCDHRN="<?????>"
+5 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","_")
+6 WRITE !?3,"HR#: ",APCDHRN,?30,"SSN: ",$PIECE(^DPT(DFN,0),U,9)
+7 WRITE !,?3,"NAME:",?9,$PIECE(^DPT(DFN,0),U)
+8 WRITE !?3,"SEX: ",?9,$$EXTSET^XBFUNC(2,.02,$PIECE(^DPT(DFN,0),U,2)),?30,"TRIBE: "
IF $PIECE(^AUPNPAT(DFN,11),U,8)]""
WRITE $PIECE(^AUTTTRI($PIECE(^AUPNPAT(DFN,11),U,8),0),U)
+9 WRITE !?3,"DOB: "
SET Y=$PIECE(^DPT(DFN,0),U,3)
IF Y]""
DO DD^%DT
WRITE ?9,Y
+10 WRITE !?3,"RESIDENCE: ",$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
+11 WRITE !?3,"FACILITY: ",$EXTRACT($PIECE(^DIC(4,DUZ(2),0),U),1,25),?38,"LOCATION: ",$PIECE(^DIC(4,$PIECE(APCDR0,U,6),0),U)
+12 IF $PIECE($GET(^AUPNVSIT(APCDR,21)),U)]""
WRITE !?3,"OUTSIDE LOCATION: ",$PIECE(^AUPNVSIT(APCDR,21),U)
+13 WRITE !!?20,"PROVIDER SIGNATURE: "
+14 WRITE !!
+15 WRITE !,$TRANSLATE($JUSTIFY("",80)," ","*")
+16 QUIT
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,APCDTDOO
+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 ;
FF ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET APCDQUIT=1
QUIT
+2 IF $DATA(IOF)
WRITE @IOF
+3 QUIT
+4 QUIT
