- 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
