APSPCP2 ;IHS/OHPRD/JCM - CHRONIC MED PROFILE;27-Dec-2004 07:31;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;**1002**;09/03/97
;THIS ROUTINE PRINTS A SUMMARY PROFILE OF ALL CURRENT CHRONIC
;MEDICATIONS TO PUT IN THE PATIENT'S CHART
;This routine is called by APSPNE4, APSPCP1 is called by option
; Modified - IHS/CIA/PLS - 03/14-04
; 12/27/04 - Line BUILD+7
Q
;
;INPUT VARIABLES- DFN
;
INIT ;EP
;NOTE: THIS EP IS CALLED BY CPCK^APSPNE4+1
S PSOZCP("COPIES")=$G(PSOZCP("COPIES",1))
S APSP("XSTAT")=""
D FMTO
G:$D(PSOZCP("FLG")) EXIT1
S:'$D(APSP1(DFN)) APSP1(DFN)=""
S %ZIS="QM"
S %ZIS("A")="Please enter PROFILE device: " D ^%ZIS
G:POP EXIT1
I $D(IO("Q")),IO=IO(0) W !!,"Sorry, you cannot queue to your screen or to a slave printer.",! K IO("Q") D ^%ZISC G INIT
I IO=IO(0)!('$D(IO("Q"))) G EN
S ZTRTN="EN^APSPCP2",ZTIO=ION ;IHS/DSD/ENM 06/14/99
F G="PSOZCP(","APSPBD","APSPED","APSP(","APSP1(","PSOSITE" S ZTSAVE(G)="" ;IHS/DSD/LWJ 9/22/99 - changed APSP to be an open array reference, added PSOSITE and APSP1 open array
S ZTDESC="CHRONIC MEDICATION PROFILE"
D ^%ZTLOAD
EXIT ;
D ^%ZISC
EXIT1 K SIG,DA,DFN,DOB,I,ISDZ,J,LRXD,PSZNAME,RFZ,RXNZ,TMP,DIC
K PSOZCP,X,POP,IO("Q"),ZTSAVE,ZTRTN,ZTDESC,ZTIO,ZTSK,Y
K ^TMP("PSOZCP",$J),DX,DY,APSPBD,APSPED,APSPASS,APSP("LAST FILL"),APSP("XSTAT"),APSPTDFN ;IHS/DSD/ENM 02/08/99
Q
;
FMTO ;EP
; Get From/To date
S X1=DT,X2=-PSOZZCP("DAYS") D C^%DTC S APSPBD=X-1_".2359",APSPED=DT_".2359"
CMEDX Q
EMPRT ;EP CALLED BY CPCK^APSPNE4+2
; NON-QUEUE PRINT MODULE
S:'$D(^TMP("PSOZCP",$J)) ^TMP("PSOZCP",$J,DFN)=""
D FMTO
I $G(APSPCPP)']"" W ! K POP,ZTSK S %ZIS="M",%ZIS("A")="Enter Profile Device: " D ^%ZIS K %ZIS("A") G:POP EXIT S APSPCPP=ION
S IOP=APSPCPP D ^%ZIS G:POP EXIT
EN ;
I $G(PSOSITE)]"" S APSPZITE=$P(^PS(59,PSOSITE,0),"^")
F PSOZCP("I")=1:1:$G(PSOZCP("COPIES"),1) D PATIENT
D EXIT
Q
;
PATIENT ;
S (DX,DY)=1 X:$D(^%ZOSF("XY"))#2 ^("XY")
U IO
S DA=""
D GETMP K APSPTDFN
F I=0:0 S DA=$O(^TMP("PSOZCP",$J,DA)) Q:DA'=+DA D START W:$E(IOST,1,2)="P-" @IOF
I PSOZCP("I")=PSOZCP("COPIES"),$D(ZTSK) K ZTSK,IO("Q")
Q
GETMP ;CREATE TMP DATA - NEW MODULE 07/30/99
S APSPTDFN=0
F S APSPTDFN=$O(APSP1(APSPTDFN)) Q:'APSPTDFN S ^TMP("PSOZCP",$J,APSPTDFN)=""
Q
START ;
K TMP("PSOZCP")
S PSOZCP("PAGE")=0
D HEADER
;
;PRESCRIPTION DFN NUMBER
S J=""
F I=0:0 S J=$O(^PS(55,DA,"P","CP",J)) Q:J'=+J D BUILD
;
;START OF PRINTING
I $D(TMP("PSOZCP"))>0 D PRINT
Q
BUILD ;
;BUILDS PRESCRIPTION DATA
;IHS/DSD/LWJ 9/21/99 - eliminate the cross reference if the
;prescription no longer exists - added next line of code
I (('$D(^PSRX(J,0)))&('$D(^PSRX(J,3)))) K ^PS(55,DA,"P","CP",J) G ENDBLD ;IHS/DSD/LWJ 9/21/99
I $D(^PSRX(J,0)),$D(^PSRX(J,3)) S APSP("LAST FILL")=$P(^PSRX(J,3),"^",1) ;IHS/DSD/ENM 02/08/99
Q:APSP("LAST FILL")<APSPBD!(APSP("LAST FILL")>APSPED) ;IHS/DSD/ENM 02/08/99
; Modified - IHS/CIA/PLS - 12/27/04 - Status field has moved
;I $D(^PSRX(J,0)) S APSP("XSTAT")=$P(^PSRX(J,0),"^",15) ;IHS/DSD/ENM 02/11/99
I $D(^PSRX(J,0)) S APSP("XSTAT")=$G(^PSRX(J,"STA"))
Q:APSP("XSTAT")=13 ;IHS/DSD/ENM 05/12/99 STATUS CHECK
Q:APSP("XSTAT")=12 ;IHS/DSD/ENM 06/14/99 STATUS CHECK
I $D(^PSRX(J,0)),$D(^PSDRUG(+$P(^(0),"^",6),0)) S TMP("PSOZCP",$P(^(0),"^",1))=J_"^"_^PSRX(J,0)
;
ENDBLD Q
PRINT ;
S PSZNAME=0
F I=0:0 S PSZNAME=$O(TMP("PSOZCP",PSZNAME)) Q:PSZNAME="" D PRINT1 I $Y+4>IOSL,IOST["C-" S DIR("A")="ENTER '^' TO HALT",DIR(0)="FO" D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) W @IOF
Q
PRINT1 ;
I $E(IOST,1,2)="P-",$Y+6>IOSL W @IOF D HEADER
S RXNZ=$P(TMP("PSOZCP",PSZNAME),"^",2) ;SETS PRESCRIPTION(RX) NUMBER
W !?60,"| | | |"
W !,RXNZ
W ?8,PSZNAME ;DRUG NAME AND STRENGTH
W ?42,$P(TMP("PSOZCP",PSZNAME),"^",8) ;QUANTITY
S LRXD=^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),3) ;SETS LAST ISSUE DATE
W ?50,$E(LRXD,4,5),"-",$E(LRXD,6,7),"-",$E(LRXD,2,3)," "
F I=1:1:3 W "|_____"
W "|"
S SIG="" S X=$P(TMP("PSOZCP",PSZNAME),"^",11) D:X]"" ^APSPSIG
W !,?10,SIG
I $D(^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),1,0)) W !,"FILLED: " D FILL ;CHECKS FOR REFILLS
Q
FILL ;
S ISDZ=$P(TMP("PSOZCP",PSZNAME),"^",14) ;SETS ORIGINAL ISSUE DATE
W $E(ISDZ,4,5),"-",$E(ISDZ,6,7),"-",$E(ISDZ,2,3)
F RFZ=0:0 S RFZ=$O(^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),1,RFZ)) Q:'RFZ W " ",$E(^(RFZ,0),4,5),"-",$E(^(0),6,7),"-",$E(^(0),2,3)
Q
;
S PSOZCP("PAGE")=PSOZCP("PAGE")+1
W !!!!,?27,"CHRONIC MEDICATION PROFILE"
W ?60,"DATE : ",$E(DT,4,5),"-",$E(DT,6,7),"-",$E(DT,2,3)
W !,?27,"SITE: ",APSPZITE ;IHS/DSD/ENM 09/06/96
W !!,$P(^DPT(DA,0),"^",1) ;PATIENTS NAME
W ?40,"CHART # ",$P(^AUPNPAT(DA,41,DUZ(2),0),"^",2) ;CHART NO.
W ?70,"Page ",PSOZCP("PAGE")
S DOB=$S($L(+$P(^DPT(DA,0),"^",3)):+$P(^DPT(DA,0),"^",3),1:"") ;DATE OF BIRTH
W !,?40,"DOB: ",$S(DOB:$E(DOB,4,5)_"-"_$E(DOB,6,7)_"-"_$E(DOB,2,3),1:"UNKNOWN")
;GET ALLERGY DATA
D GMR
W !!,"RX# DRUG",?42,"QTY",?50,"LAST FILLED",!!
Q
;
COPIES ;EP
K PSOZP("FLG"),DIRUT,DTOUT
S DIR(0)="NO^1:10:0"
S DIR("B")=1,DIR("A")="Number of Chronic Med Profile copies"
D ^DIR
I $D(DIRUT)!($D(DTOUT)) S PSOZCP("FLG")="" G COPIESX
S PSOZCP("COPIES")=$S(+Y>0:+Y,1:1)
COPIESX ;
Q
GMR X "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q" I $T D:'$D(PSOPTPST) GMRA
Q K SC,I1,VAROOT,Y,AL,I,X,Y,PSCNT,PSLC,PSDIS Q
GMRA W !,"REACTIONS: " D ^GMRADPT S I1=0 F I=0:0 S I=$O(GMRAL(I)) Q:I'>0 W:I1 ", " S AL=$P(GMRAL(I),"^",2) W:$X+$L(AL)>75 !?5 W AL S I1=1
K GMRA,GMRAL Q
APSPCP2 ;IHS/OHPRD/JCM - CHRONIC MED PROFILE;27-Dec-2004 07:31;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1002**;09/03/97
+2 ;THIS ROUTINE PRINTS A SUMMARY PROFILE OF ALL CURRENT CHRONIC
+3 ;MEDICATIONS TO PUT IN THE PATIENT'S CHART
+4 ;This routine is called by APSPNE4, APSPCP1 is called by option
+5 ; Modified - IHS/CIA/PLS - 03/14-04
+6 ; 12/27/04 - Line BUILD+7
+7 QUIT
+8 ;
+9 ;INPUT VARIABLES- DFN
+10 ;
INIT ;EP
+1 ;NOTE: THIS EP IS CALLED BY CPCK^APSPNE4+1
+2 SET PSOZCP("COPIES")=$GET(PSOZCP("COPIES",1))
+3 SET APSP("XSTAT")=""
+4 DO FMTO
+5 IF $DATA(PSOZCP("FLG"))
GOTO EXIT1
+6 IF '$DATA(APSP1(DFN))
SET APSP1(DFN)=""
+7 SET %ZIS="QM"
+8 SET %ZIS("A")="Please enter PROFILE device: "
DO ^%ZIS
+9 IF POP
GOTO EXIT1
+10 IF $DATA(IO("Q"))
IF IO=IO(0)
WRITE !!,"Sorry, you cannot queue to your screen or to a slave printer.",!
KILL IO("Q")
DO ^%ZISC
GOTO INIT
+11 IF IO=IO(0)!('$DATA(IO("Q")))
GOTO EN
+12 ;IHS/DSD/ENM 06/14/99
SET ZTRTN="EN^APSPCP2"
SET ZTIO=ION
+13 ;IHS/DSD/LWJ 9/22/99 - changed APSP to be an open array reference, added PSOSITE and APSP1 open array
FOR G="PSOZCP(","APSPBD","APSPED","APSP(","APSP1(","PSOSITE"
SET ZTSAVE(G)=""
+14 SET ZTDESC="CHRONIC MEDICATION PROFILE"
+15 DO ^%ZTLOAD
EXIT ;
+1 DO ^%ZISC
EXIT1 KILL SIG,DA,DFN,DOB,I,ISDZ,J,LRXD,PSZNAME,RFZ,RXNZ,TMP,DIC
+1 KILL PSOZCP,X,POP,IO("Q"),ZTSAVE,ZTRTN,ZTDESC,ZTIO,ZTSK,Y
+2 ;IHS/DSD/ENM 02/08/99
KILL ^TMP("PSOZCP",$JOB),DX,DY,APSPBD,APSPED,APSPASS,APSP("LAST FILL"),APSP("XSTAT"),APSPTDFN
+3 QUIT
+4 ;
FMTO ;EP
+1 ; Get From/To date
+2 SET X1=DT
SET X2=-PSOZZCP("DAYS")
DO C^%DTC
SET APSPBD=X-1_".2359"
SET APSPED=DT_".2359"
CMEDX QUIT
EMPRT ;EP CALLED BY CPCK^APSPNE4+2
+1 ; NON-QUEUE PRINT MODULE
+2 IF '$DATA(^TMP("PSOZCP",$JOB))
SET ^TMP("PSOZCP",$JOB,DFN)=""
+3 DO FMTO
+4 IF $GET(APSPCPP)']""
WRITE !
KILL POP,ZTSK
SET %ZIS="M"
SET %ZIS("A")="Enter Profile Device: "
DO ^%ZIS
KILL %ZIS("A")
IF POP
GOTO EXIT
SET APSPCPP=ION
+5 SET IOP=APSPCPP
DO ^%ZIS
IF POP
GOTO EXIT
EN ;
+1 IF $GET(PSOSITE)]""
SET APSPZITE=$PIECE(^PS(59,PSOSITE,0),"^")
+2 FOR PSOZCP("I")=1:1:$GET(PSOZCP("COPIES"),1)
DO PATIENT
+3 DO EXIT
+4 QUIT
+5 ;
PATIENT ;
+1 SET (DX,DY)=1
IF $DATA(^%ZOSF("XY"))#2
XECUTE ^("XY")
+2 USE IO
+3 SET DA=""
+4 DO GETMP
KILL APSPTDFN
+5 FOR I=0:0
SET DA=$ORDER(^TMP("PSOZCP",$JOB,DA))
IF DA'=+DA
QUIT
DO START
IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+6 IF PSOZCP("I")=PSOZCP("COPIES")
IF $DATA(ZTSK)
KILL ZTSK,IO("Q")
+7 QUIT
GETMP ;CREATE TMP DATA - NEW MODULE 07/30/99
+1 SET APSPTDFN=0
+2 FOR
SET APSPTDFN=$ORDER(APSP1(APSPTDFN))
IF 'APSPTDFN
QUIT
SET ^TMP("PSOZCP",$JOB,APSPTDFN)=""
+3 QUIT
START ;
+1 KILL TMP("PSOZCP")
+2 SET PSOZCP("PAGE")=0
+3 DO HEADER
+4 ;
+5 ;PRESCRIPTION DFN NUMBER
+6 SET J=""
+7 FOR I=0:0
SET J=$ORDER(^PS(55,DA,"P","CP",J))
IF J'=+J
QUIT
DO BUILD
+8 ;
+9 ;START OF PRINTING
+10 IF $DATA(TMP("PSOZCP"))>0
DO PRINT
+11 QUIT
BUILD ;
+1 ;BUILDS PRESCRIPTION DATA
+2 ;IHS/DSD/LWJ 9/21/99 - eliminate the cross reference if the
+3 ;prescription no longer exists - added next line of code
+4 ;IHS/DSD/LWJ 9/21/99
IF (('$DATA(^PSRX(J,0)))&('$DATA(^PSRX(J,3))))
KILL ^PS(55,DA,"P","CP",J)
GOTO ENDBLD
+5 ;IHS/DSD/ENM 02/08/99
IF $DATA(^PSRX(J,0))
IF $DATA(^PSRX(J,3))
SET APSP("LAST FILL")=$PIECE(^PSRX(J,3),"^",1)
+6 ;IHS/DSD/ENM 02/08/99
IF APSP("LAST FILL")<APSPBD!(APSP("LAST FILL")>APSPED)
QUIT
+7 ; Modified - IHS/CIA/PLS - 12/27/04 - Status field has moved
+8 ;I $D(^PSRX(J,0)) S APSP("XSTAT")=$P(^PSRX(J,0),"^",15) ;IHS/DSD/ENM 02/11/99
+9 IF $DATA(^PSRX(J,0))
SET APSP("XSTAT")=$GET(^PSRX(J,"STA"))
+10 ;IHS/DSD/ENM 05/12/99 STATUS CHECK
IF APSP("XSTAT")=13
QUIT
+11 ;IHS/DSD/ENM 06/14/99 STATUS CHECK
IF APSP("XSTAT")=12
QUIT
+12 IF $DATA(^PSRX(J,0))
IF $DATA(^PSDRUG(+$PIECE(^(0),"^",6),0))
SET TMP("PSOZCP",$PIECE(^(0),"^",1))=J_"^"_^PSRX(J,0)
+13 ;
ENDBLD QUIT
PRINT ;
+1 SET PSZNAME=0
+2 FOR I=0:0
SET PSZNAME=$ORDER(TMP("PSOZCP",PSZNAME))
IF PSZNAME=""
QUIT
DO PRINT1
IF $Y+4>IOSL
IF IOST["C-"
SET DIR("A")="ENTER '^' TO HALT"
SET DIR(0)="FO"
DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
WRITE @IOF
+3 QUIT
PRINT1 ;
+1 IF $EXTRACT(IOST,1,2)="P-"
IF $Y+6>IOSL
WRITE @IOF
DO HEADER
+2 ;SETS PRESCRIPTION(RX) NUMBER
SET RXNZ=$PIECE(TMP("PSOZCP",PSZNAME),"^",2)
+3 WRITE !?60,"| | | |"
+4 WRITE !,RXNZ
+5 ;DRUG NAME AND STRENGTH
WRITE ?8,PSZNAME
+6 ;QUANTITY
WRITE ?42,$PIECE(TMP("PSOZCP",PSZNAME),"^",8)
+7 ;SETS LAST ISSUE DATE
SET LRXD=^PSRX($PIECE(TMP("PSOZCP",PSZNAME),"^",1),3)
+8 WRITE ?50,$EXTRACT(LRXD,4,5),"-",$EXTRACT(LRXD,6,7),"-",$EXTRACT(LRXD,2,3)," "
+9 FOR I=1:1:3
WRITE "|_____"
+10 WRITE "|"
+11 SET SIG=""
SET X=$PIECE(TMP("PSOZCP",PSZNAME),"^",11)
IF X]""
DO ^APSPSIG
+12 WRITE !,?10,SIG
+13 ;CHECKS FOR REFILLS
IF $DATA(^PSRX($PIECE(TMP("PSOZCP",PSZNAME),"^",1),1,0))
WRITE !,"FILLED: "
DO FILL
+14 QUIT
FILL ;
+1 ;SETS ORIGINAL ISSUE DATE
SET ISDZ=$PIECE(TMP("PSOZCP",PSZNAME),"^",14)
+2 WRITE $EXTRACT(ISDZ,4,5),"-",$EXTRACT(ISDZ,6,7),"-",$EXTRACT(ISDZ,2,3)
+3 FOR RFZ=0:0
SET RFZ=$ORDER(^PSRX($PIECE(TMP("PSOZCP",PSZNAME),"^",1),1,RFZ))
IF 'RFZ
QUIT
WRITE " ",$EXTRACT(^(RFZ,0),4,5),"-",$EXTRACT(^(0),6,7),"-",$EXTRACT(^(0),2,3)
+4 QUIT
+5 ;
+1 SET PSOZCP("PAGE")=PSOZCP("PAGE")+1
+2 WRITE !!!!,?27,"CHRONIC MEDICATION PROFILE"
+3 WRITE ?60,"DATE : ",$EXTRACT(DT,4,5),"-",$EXTRACT(DT,6,7),"-",$EXTRACT(DT,2,3)
+4 ;IHS/DSD/ENM 09/06/96
WRITE !,?27,"SITE: ",APSPZITE
+5 ;PATIENTS NAME
WRITE !!,$PIECE(^DPT(DA,0),"^",1)
+6 ;CHART NO.
WRITE ?40,"CHART # ",$PIECE(^AUPNPAT(DA,41,DUZ(2),0),"^",2)
+7 WRITE ?70,"Page ",PSOZCP("PAGE")
+8 ;DATE OF BIRTH
SET DOB=$SELECT($LENGTH(+$PIECE(^DPT(DA,0),"^",3)):+$PIECE(^DPT(DA,0),"^",3),1:"")
+9 WRITE !,?40,"DOB: ",$SELECT(DOB:$EXTRACT(DOB,4,5)_"-"_$EXTRACT(DOB,6,7)_"-"_$EXTRACT(DOB,2,3),1:"UNKNOWN")
+10 ;GET ALLERGY DATA
+11 DO GMR
+12 WRITE !!,"RX# DRUG",?42,"QTY",?50,"LAST FILLED",!!
+13 QUIT
+14 ;
COPIES ;EP
+1 KILL PSOZP("FLG"),DIRUT,DTOUT
+2 SET DIR(0)="NO^1:10:0"
+3 SET DIR("B")=1
SET DIR("A")="Number of Chronic Med Profile copies"
+4 DO ^DIR
+5 IF $DATA(DIRUT)!($DATA(DTOUT))
SET PSOZCP("FLG")=""
GOTO COPIESX
+6 SET PSOZCP("COPIES")=$SELECT(+Y>0:+Y,1:1)
COPIESX ;
+1 QUIT
GMR XECUTE "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q"
IF $TEST
IF '$DATA(PSOPTPST)
DO GMRA
Q KILL SC,I1,VAROOT,Y,AL,I,X,Y,PSCNT,PSLC,PSDIS
QUIT
GMRA WRITE !,"REACTIONS: "
DO ^GMRADPT
SET I1=0
FOR I=0:0
SET I=$ORDER(GMRAL(I))
IF I'>0
QUIT
IF I1
WRITE ", "
SET AL=$PIECE(GMRAL(I),"^",2)
IF $X+$LENGTH(AL)>75
WRITE !?5
WRITE AL
SET I1=1
+1 KILL GMRA,GMRAL
QUIT
