APSPCP1 ; IHS/DSD/ENM/CIA/PLS - CHRONIC MED PROFILE ;07-Jan-2013 15:53;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;**2,1002,1013,1015**;09/03/97;Build 62
;THIS ROUTINE PRINTS A SUMMARY PROFILE OF ALL CURRENT CHRONIC
;MEDICATIONS TO PUT IN THE PATIENT'S CHART
;This routine is called by 'APSP CHRONIC MED PROFILE' Option
;
;INPUT VARIABLES- DFN
;OUTPUT VARIABLES- DA,DFN,DOB,DT,I,ISDZ,J,LRXD,PSZNAME,RFZ,RXNZ,SIG
;TMP("PSOZCP"),X,X1,X2,PSOZCP("PAGE"),^TMP("PSOZCP",$J,DFN)
;%ZIS,DIC,DIC(0)
;
;EXTERNAL CALLS- C^%DTC,^%ZIS,^DIC,^%ZTLOAD,^TMP("PSOZCP",$J)
; Modified - IHS/CIA/PLS - 12/27/04 - Line BUILD+7
; IHS/MSC/PLS - 11/10/11 - TallMan support
; - 01/07/13 - Fix for I variable conflict with FileMan
K DFN S DFN="",APSPCNT=0
S APSP("XSTAT")=""
D FMTO I $D(PSOZCP("FLG")) G EXIT1
S APSPASS=1
S PSOZCP="" F S DIC="^AUPNPAT(",DIC(0)="QEAM" D ^DIC Q:Y<0 S DFN=+Y,APSPCNT=APSPCNT+1 S:$D(^PS(55,DFN,"P","CP")) APSP1(DFN)="",ZTSAVE("APSP1(")="" W:'$D(^PS(55,DFN,"P","CP")) !,?20,*7,"PATIENT DOES NOT HAVE ANY CHRONIC MEDICATIONS"
G:APSPCNT'>0 EXIT1
;
INIT ;ENTRY POINT IF DFN ALREADY DEFINED
D COPIES ; Asks number of copies
D:$G(APSPASS)'=1 FMTO ;IHS/DSD/ENM 02/05/99 ASK FOR NUMBER OF DAYS
I $D(PSOZCP("FLG")) G EXIT1
S:'$D(APSP1(DFN)) APSP1(DFN)=""
S %ZIS="QM"
S %ZIS("A")="Please enter PROFILE device: " D ^%ZIS
I POP G 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^APSPCP1",ZTIO=ION
S ZTSAVE("PSOZCP(""COPIES"")")="",ZTSAVE("%APSITE")="",ZTSAVE("PSOSITE")="" ;IHS/DSD/ENM 09/02/96 %APSITE,PSOSITE SAVED
S ZTSAVE("APSPBD")="",ZTSAVE("APSPED")="",ZTSAVE("APSP(""XSTAT"")")="" ;IHS/DSD/ENM 02/05/99
S ZTDESC="CHRONIC MEDICATION PROFILE"
D ^%ZTLOAD
G EXIT
;
FMTO ;EP
;-------------------------------------------------------------------
;IHS/DSD/ENM 02/08/99 CHRONIC MED DATE SET
;IHS/DSD/LWJ 09/10/99 V6.0,patch 2 - if the user enters the program
; from other than the main pharmacy menu we need to prompt for the div,
; days for report..nxt line of code added
I '$D(PSOPAR) D ^PSOLSET S PSOZCP("DAYS")=$G(PSOZZCP("DAYS")) I PSOZCP("DAYS")'="" G CMEDXA ;/IHS/DSD/LWJ 09/10/99
S PSOZCP("DAYS")=""
K PSOZP("FLG"),DIRUT,DTOUT
S DIR(0)="NO^1:999:0"
S DIR("B")=90,DIR("A")="Number of Days For Chronic Med Profile"
D ^DIR
I $D(DIRUT)!($D(DTOUT)) S PSOZCP("FLG")="" G CMEDX
S PSOZCP("DAYS")=$S(+Y>0:+Y,1:90)
CMEDXA S X1=DT,X2=-PSOZCP("DAYS") D C^%DTC S APSPBD=X-1_".2359",APSPED=DT_".2359" ;IHS/DSD/LWJ 9/10/99 label added to line
CMEDX Q
;---------------------------------------------------------------------
EN ;
I $G(PSOSITE)]"" S APSPZITE=$P(^PS(59,PSOSITE,0),"^")
F PSOZCP("I")=1:1:PSOZCP("COPIES") D PATIENT
D EXIT
Q
;
PATIENT ;
S (DX,DY)=1 X:$D(^%ZOSF("XY"))#2 ^("XY")
U IO
S DA=""
K ^TMP("PSOZCP",$J)
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(ZTQUEUED) S ZTREQ="@"
Q
GETMP ;CREATE TMP DATA
S APSPTDFN=0
F S APSPTDFN=$O(APSP1(APSPTDFN)) Q:'APSPTDFN S ^TMP("PSOZCP",$J,APSPTDFN)=""
Q
EXIT ;
D ^%ZISC
EXIT1 K SIG,DA,DFN,DOB,I,ISDZ,J,LRXD,PSZNAME,RFZ,RXNZ,TMP,DIC
K PSOZCP,X,POP,IO("Q"),%ZIS,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/05/99
K APSP1,AGE,APSPCNT,APSPZITE
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
N DRUGN
I (('$D(^PSRX(J,0)))&('$D(^PSRX(J,3)))) K ^PS(55,DA,"P","CP",J) G ENDBLD
I $D(^PSRX(J,0)),$D(^PSRX(J,3)) S APSP("LAST FILL")=$P(^PSRX(J,3),"^",1)
Q:APSP("LAST FILL")<APSPBD!(APSP("LAST FILL")>APSPED)
; IHS/CIA/PLS - 12/27/04 - Status field was moved
;I $D(^PSRX(J,0)) S APSP("XSTAT")=$P(^PSRX(J,0),"^",15)
I $D(^PSRX(J,0)) S APSP("XSTAT")=$G(^PSRX(J,"STA"))
Q:APSP("XSTAT")=13 ; DELETED STATUS CHECK
Q:APSP("XSTAT")=12 ; CANCELLED STATUS CHECK
;IHS/MSC/PLS - 11/10/11 - P1013
;I $D(^PSRX(J,0)),$D(^PSDRUG(+$P(^(0),"^",6),0)) S TMP("PSOZCP",$P(^(0),"^",1))=J_"^"_^PSRX(J,0)
I $D(^PSRX(J,0)),$D(^PSDRUG(+$P(^(0),U,6),0)) D
.S DRUGN=^PSDRUG(+$P(^PSRX(J,0),U,6),0)
.S TMP("PSOZCP",$$UP^XLFSTR(DRUGN))=J_U_^PSRX(J,0)
;
ENDBLD Q
PRINT ;
S PSZNAME=0
F I=0:0 S PSZNAME=$O(TMP("PSOZCP",PSZNAME)) Q:PSZNAME="" D PRINT1 I $E(IOST,1,2)'="P-",$Y+6>IOSL S DIR(0)="E" D ^DIR Q:X="^"!($D(DTOUT)) W @IOF
Q
PRINT1 ;
N DATA
I $E(IOST,1,2)="P-",$Y+6>IOSL W @IOF D HEADER
I $E(IOST,1,2)="C-",$Y+6>IOSL W @IOF D HEADER
S DATA=TMP("PSOZCP",PSZNAME)
;S RXNZ=$P(TMP("PSOZCP",PSZNAME),"^",2) ;SETS PRESCRIPTION(RX) NUMBER
W !?60,"| | | |"
;W !,RXNZ
W !,$P(DATA,U,2)
;W ?8,PSZNAME ;DRUG NAME AND STRENGTH
W ?8,$P(^PSDRUG($P(DATA,U,7),0),U) ;DRUG NAME AND STRENGTH
;W ?42,$P(TMP("PSOZCP",PSZNAME),"^",8) ;QUANTITY
W ?42,$P(DATA,U,8) ;QUANTITY
;S LRXD=^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),3) ;SETS LAST ISSUE DATE
S LRXD=+^PSRX($P(DATA,U),3)
W ?50,$E(LRXD,4,5),"-",$E(LRXD,6,7),"-",$E(LRXD,2,3)," "
F I=1:1:3 W "|_____"
W "|"
;
;W !,?10,$P(TMP("PSOZCP",PSZNAME),"^",11) ;SIG
S SIG="" S X=$P(TMP("PSOZCP",PSZNAME),"^",11) D:X]"" ^APSPCP
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) ;IHS/DSD/ENM 05/24/96 $O ADDED
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: ",$G(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")
D GMR ;GET ALLERGY DATA
W !!,"RX# DRUG",?42,"QTY",?50,"LAST FILLED",!!
Q
;
COPIES ;
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 K DIR
I $D(DIRUT)!($D(DTOUT)) S PSOZCP("FLG")="" G COPIESX
S PSOZCP("COPIES")=$S(+Y>0:+Y,1:1)
COPIESX ;
Q
;GET ALLERGY INFORMATION
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
APSPCP1 ; IHS/DSD/ENM/CIA/PLS - CHRONIC MED PROFILE ;07-Jan-2013 15:53;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**2,1002,1013,1015**;09/03/97;Build 62
+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 'APSP CHRONIC MED PROFILE' Option
+5 ;
+6 ;INPUT VARIABLES- DFN
+7 ;OUTPUT VARIABLES- DA,DFN,DOB,DT,I,ISDZ,J,LRXD,PSZNAME,RFZ,RXNZ,SIG
+8 ;TMP("PSOZCP"),X,X1,X2,PSOZCP("PAGE"),^TMP("PSOZCP",$J,DFN)
+9 ;%ZIS,DIC,DIC(0)
+10 ;
+11 ;EXTERNAL CALLS- C^%DTC,^%ZIS,^DIC,^%ZTLOAD,^TMP("PSOZCP",$J)
+12 ; Modified - IHS/CIA/PLS - 12/27/04 - Line BUILD+7
+13 ; IHS/MSC/PLS - 11/10/11 - TallMan support
+14 ; - 01/07/13 - Fix for I variable conflict with FileMan
+15 KILL DFN
SET DFN=""
SET APSPCNT=0
+16 SET APSP("XSTAT")=""
+17 DO FMTO
IF $DATA(PSOZCP("FLG"))
GOTO EXIT1
+18 SET APSPASS=1
+19 SET PSOZCP=""
FOR
SET DIC="^AUPNPAT("
SET DIC(0)="QEAM"
DO ^DIC
IF Y<0
QUIT
SET DFN=+Y
SET APSPCNT=APSPCNT+1
IF $DATA(^PS(55,DFN,"P","CP"))
SET APSP1(DFN)=""
SET ZTSAVE("APSP1(")=""
IF '$DATA(^PS(55,DFN,"P","CP"))
WRITE !,?20,*7,"PATIENT DOES NOT HAVE ANY CHRONIC MEDICATIONS"
+20 IF APSPCNT'>0
GOTO EXIT1
+21 ;
INIT ;ENTRY POINT IF DFN ALREADY DEFINED
+1 ; Asks number of copies
DO COPIES
+2 ;IHS/DSD/ENM 02/05/99 ASK FOR NUMBER OF DAYS
IF $GET(APSPASS)'=1
DO FMTO
+3 IF $DATA(PSOZCP("FLG"))
GOTO EXIT1
+4 IF '$DATA(APSP1(DFN))
SET APSP1(DFN)=""
+5 SET %ZIS="QM"
+6 SET %ZIS("A")="Please enter PROFILE device: "
DO ^%ZIS
+7 IF POP
GOTO EXIT1
+8 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
+9 IF IO=IO(0)!('$DATA(IO("Q")))
GOTO EN
+10 SET ZTRTN="EN^APSPCP1"
SET ZTIO=ION
+11 ;IHS/DSD/ENM 09/02/96 %APSITE,PSOSITE SAVED
SET ZTSAVE("PSOZCP(""COPIES"")")=""
SET ZTSAVE("%APSITE")=""
SET ZTSAVE("PSOSITE")=""
+12 ;IHS/DSD/ENM 02/05/99
SET ZTSAVE("APSPBD")=""
SET ZTSAVE("APSPED")=""
SET ZTSAVE("APSP(""XSTAT"")")=""
+13 SET ZTDESC="CHRONIC MEDICATION PROFILE"
+14 DO ^%ZTLOAD
+15 GOTO EXIT
+16 ;
FMTO ;EP
+1 ;-------------------------------------------------------------------
+2 ;IHS/DSD/ENM 02/08/99 CHRONIC MED DATE SET
+3 ;IHS/DSD/LWJ 09/10/99 V6.0,patch 2 - if the user enters the program
+4 ; from other than the main pharmacy menu we need to prompt for the div,
+5 ; days for report..nxt line of code added
+6 ;/IHS/DSD/LWJ 09/10/99
IF '$DATA(PSOPAR)
DO ^PSOLSET
SET PSOZCP("DAYS")=$GET(PSOZZCP("DAYS"))
IF PSOZCP("DAYS")'=""
GOTO CMEDXA
+7 SET PSOZCP("DAYS")=""
+8 KILL PSOZP("FLG"),DIRUT,DTOUT
+9 SET DIR(0)="NO^1:999:0"
+10 SET DIR("B")=90
SET DIR("A")="Number of Days For Chronic Med Profile"
+11 DO ^DIR
+12 IF $DATA(DIRUT)!($DATA(DTOUT))
SET PSOZCP("FLG")=""
GOTO CMEDX
+13 SET PSOZCP("DAYS")=$SELECT(+Y>0:+Y,1:90)
CMEDXA ;IHS/DSD/LWJ 9/10/99 label added to line
SET X1=DT
SET X2=-PSOZCP("DAYS")
DO C^%DTC
SET APSPBD=X-1_".2359"
SET APSPED=DT_".2359"
CMEDX QUIT
+1 ;---------------------------------------------------------------------
EN ;
+1 IF $GET(PSOSITE)]""
SET APSPZITE=$PIECE(^PS(59,PSOSITE,0),"^")
+2 FOR PSOZCP("I")=1:1:PSOZCP("COPIES")
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 KILL ^TMP("PSOZCP",$JOB)
+5 DO GETMP
KILL APSPTDFN
+6 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
+7 IF PSOZCP("I")=PSOZCP("COPIES")
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+8 QUIT
GETMP ;CREATE TMP DATA
+1 SET APSPTDFN=0
+2 FOR
SET APSPTDFN=$ORDER(APSP1(APSPTDFN))
IF 'APSPTDFN
QUIT
SET ^TMP("PSOZCP",$JOB,APSPTDFN)=""
+3 QUIT
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"),%ZIS,ZTSAVE,ZTRTN,ZTDESC,ZTIO,ZTSK,Y
+2 ;IHS/DSD/ENM 02/05/99
KILL ^TMP("PSOZCP",$JOB),DX,DY,APSPBD,APSPED,APSPASS,APSP("LAST FILL"),APSP("XSTAT"),APSPTDFN
+3 KILL APSP1,AGE,APSPCNT,APSPZITE
+4 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 NEW DRUGN
+5 IF (('$DATA(^PSRX(J,0)))&('$DATA(^PSRX(J,3))))
KILL ^PS(55,DA,"P","CP",J)
GOTO ENDBLD
+6 IF $DATA(^PSRX(J,0))
IF $DATA(^PSRX(J,3))
SET APSP("LAST FILL")=$PIECE(^PSRX(J,3),"^",1)
+7 IF APSP("LAST FILL")<APSPBD!(APSP("LAST FILL")>APSPED)
QUIT
+8 ; IHS/CIA/PLS - 12/27/04 - Status field was moved
+9 ;I $D(^PSRX(J,0)) S APSP("XSTAT")=$P(^PSRX(J,0),"^",15)
+10 IF $DATA(^PSRX(J,0))
SET APSP("XSTAT")=$GET(^PSRX(J,"STA"))
+11 ; DELETED STATUS CHECK
IF APSP("XSTAT")=13
QUIT
+12 ; CANCELLED STATUS CHECK
IF APSP("XSTAT")=12
QUIT
+13 ;IHS/MSC/PLS - 11/10/11 - P1013
+14 ;I $D(^PSRX(J,0)),$D(^PSDRUG(+$P(^(0),"^",6),0)) S TMP("PSOZCP",$P(^(0),"^",1))=J_"^"_^PSRX(J,0)
+15 IF $DATA(^PSRX(J,0))
IF $DATA(^PSDRUG(+$PIECE(^(0),U,6),0))
Begin DoDot:1
+16 SET DRUGN=^PSDRUG(+$PIECE(^PSRX(J,0),U,6),0)
+17 SET TMP("PSOZCP",$$UP^XLFSTR(DRUGN))=J_U_^PSRX(J,0)
End DoDot:1
+18 ;
ENDBLD QUIT
PRINT ;
+1 SET PSZNAME=0
+2 FOR I=0:0
SET PSZNAME=$ORDER(TMP("PSOZCP",PSZNAME))
IF PSZNAME=""
QUIT
DO PRINT1
IF $EXTRACT(IOST,1,2)'="P-"
IF $Y+6>IOSL
SET DIR(0)="E"
DO ^DIR
IF X="^"!($DATA(DTOUT))
QUIT
WRITE @IOF
+3 QUIT
PRINT1 ;
+1 NEW DATA
+2 IF $EXTRACT(IOST,1,2)="P-"
IF $Y+6>IOSL
WRITE @IOF
DO HEADER
+3 IF $EXTRACT(IOST,1,2)="C-"
IF $Y+6>IOSL
WRITE @IOF
DO HEADER
+4 SET DATA=TMP("PSOZCP",PSZNAME)
+5 ;S RXNZ=$P(TMP("PSOZCP",PSZNAME),"^",2) ;SETS PRESCRIPTION(RX) NUMBER
+6 WRITE !?60,"| | | |"
+7 ;W !,RXNZ
+8 WRITE !,$PIECE(DATA,U,2)
+9 ;W ?8,PSZNAME ;DRUG NAME AND STRENGTH
+10 ;DRUG NAME AND STRENGTH
WRITE ?8,$PIECE(^PSDRUG($PIECE(DATA,U,7),0),U)
+11 ;W ?42,$P(TMP("PSOZCP",PSZNAME),"^",8) ;QUANTITY
+12 ;QUANTITY
WRITE ?42,$PIECE(DATA,U,8)
+13 ;S LRXD=^PSRX($P(TMP("PSOZCP",PSZNAME),"^",1),3) ;SETS LAST ISSUE DATE
+14 SET LRXD=+^PSRX($PIECE(DATA,U),3)
+15 WRITE ?50,$EXTRACT(LRXD,4,5),"-",$EXTRACT(LRXD,6,7),"-",$EXTRACT(LRXD,2,3)," "
+16 FOR I=1:1:3
WRITE "|_____"
+17 WRITE "|"
+18 ;
+19 ;W !,?10,$P(TMP("PSOZCP",PSZNAME),"^",11) ;SIG
+20 SET SIG=""
SET X=$PIECE(TMP("PSOZCP",PSZNAME),"^",11)
IF X]""
DO ^APSPCP
+21 WRITE !,?10,SIG
+22 ;CHECKS FOR REFILLS
IF $DATA(^PSRX($PIECE(TMP("PSOZCP",PSZNAME),"^",1),1,0))
WRITE !,"FILLED: "
DO FILL
+23 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 ;IHS/DSD/ENM 05/24/96 $O ADDED
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: ",$GET(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
DO GMR
+11 WRITE !!,"RX# DRUG",?42,"QTY",?50,"LAST FILLED",!!
+12 QUIT
+13 ;
COPIES ;
+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
KILL 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
+2 ;GET ALLERGY INFORMATION
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
