PSOSD1 ;BHAM ISC/SAB/JMB - action or informational profile cont. ;29-May-2012 15:14;PLS
;;7.0;OUTPATIENT PHARMACY;**2,17,19,22,40,49,66,107,110,132,1005,233,258,240,320,326,1015**;DEC 1997;Build 62
;External reference to ^PS(59.7 is supported by DBIA 694
;
; Modified - IHS/CIA/PLS - 12/11/03 - Line HD+6 and HD+12
INIT N PSOPTLK
S PRF="" F PSOI=0:0 S DIC(0)="QEAM" D EN^PSOPATLK S Y=PSOPTLK Q:Y<1 D
.S PRF=PRF_+Y_",",DFN=+Y D DEM^VADPT I +VADM(6) W !,"Patient Expired on "_$P(VADM(6),"^",2),! S DOD(DFN)=$P(VADM(6),"^",2) K DFN
.I $L(PRF)>240 W !,$C(7),"MAX NUMBER OF PATIENTS HAS BEEN REACHED" Q
Q:'$L(PRF) D DAYS G:$D(DUOUT)!($D(DTOUT)) EXIT^PSOSD
DEV N PSOBARS,PSOBAR0,PSOBAR1 K %ZIS,IOP,ZTSK,ZTQUEUED S PSOION=ION,%ZIS="QM",%ZIS("B")="",%ZIS("A")=$S(PSTYPE:"Select a Printer: ",1:"DEVICE: ") D ^%ZIS K %ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION G EXIT
I $E(IOST)["C",PSTYPE D ^%ZISC W $C(7),!!,"Action Profiles MUST BE SENT TO A PRINTER !!",!,"ONLY INFORMATIONAL PROFILES ARE ALLOWED TO PRINT TO SCREEN !!",! G DEV
S PSOIOS=IOS D DEVBAR^PSOBMST S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1
S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^"))
K PSOION I $D(IO("Q")) S ZTDESC="Outpatient Pharmacy Action Profile",ZTRTN="START^PSOSD1",ZTSAVE("ZTREQ")="@" D D EXIT Q:$G(LM) G ^PSOSD
.F G="PSORM","PSOPOL","PSONUM","PSOSYS","PSOINST","PSOBAR3","PSOBAR4","PSOBAR2","PSOPAR","PSOPAR7","PRF","PSDAYS","PSDATE","PSTYPE","PSOSITE","PSDATE","PSDAY" S:$D(@G) ZTSAVE(G)=""
.S ZTSAVE("DOD*")="",ZTSAVE("PSOBAR*")="" D ^%ZTLOAD W:$D(ZTSK) !,"Report Queued to Print !!",! K:'$G(LM) ZTSK,IO("Q")
D START G:'$G(LM) ^PSOSD
Q
START U IO S PSTYPE=$S($D(PSTYPE):PSTYPE,1:0),$P(LINE,"-",132)="-"
F PSIX=1:1 S DFN=$P(PRF,",",PSIX) G:DFN']"" EXIT D ELIG S PAGE=1 D G:$G(PSQFLG)!($D(DTOUT))!($D(DUOUT)) EXIT
.D PAT^PSOSD Q:$D(DTOUT)!($D(DUOUT)) D Q:PSQFLG D RXPAD:PSTYPE D ENSTUFF^PSODACT
..Q:$D(DUOUT)!($D(DTOUT)) S PSQFLG=0 D ^PSOSD3,NVA^PSOSD3,EN^PSORMRXP(DFN)
EXIT I '$D(PSONOPG) W ! D ^%ZISC K DFN
W:$D(PSONOPG)&('$D(ORVP)) @IOF
K ^TMP($J,"PRF"),^("ACT"),ADDR,ADDRFL,CLASS,CNDT,CNT,DRUG,CLAPP,HDFL,I,II,J,L,LINE,P,PAGE,PSDOB,PSIIX,PSNAME,PSOI,PSQFLG,PSSN,DFN,PSIX,PAGE,PGM,LINE,PRF,PSTYPE,PSDATE,PSDAYS,VAL,VAR,RX,RX0,RX3,RX2,ST,ST0,PSDAY,RF,RFS,PSOBAR3,PSOBAR4,PSOBAR2
D KVA^VADPT K DOD,FILL,DIC,PSCNT,PSDT,PCLASS,PHYS,ZCLASS,PSOPRINT,RXNODE,DIR,X1,X2,PSONUM,PSOPOLP,PSSN4
Q
;
DAYS K DIR S DIR("A")="Profile Expiration/Discontinued Cutoff",DIR("B")=120,DIR(0)="N^0:9999:0",DIR("?",1)="Enter the number of days which will cut discontinued and expired Rx's from",DIR("?")="the profile."
D ^DIR Q:$D(DTOUT)!($D(DUOUT)) S PSDAYS=X K DIR S X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X
Q
;
DFN S:'$D(PSORM) PSORM=1
S PSOIOS=IOS D DEVBAR^PSOBMST S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1
S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^"))
W:$D(PSONOPG)&($G(PSONOPG)'=2) @IOF I '$G(PSOSITE) S PSOSITE=$O(^PS(59,0))
S PRF=DFN_"," D:'$G(PSDAYS) G START
.S PSDAYS=120,X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X
Q
;
ELIG S PSOPRINT=""
D ELIG^VADPT
Q:'$D(VAEL(4))
Q:+VAEL(4)'=1
I $D(VAEL(3)),+VAEL(3)=1,($P(VAEL(3),"^",2)<50) S PSOPRINT="SC NSC"
D KVAR^VADPT
Q
;
RXPAD N K Q:$G(DOD(DFN))]"" D HD F CNT=1:1:4 S LF="!?45" D Q:$Y+14>IOSL
.W !?4,"Name: "_PSNAME,?58,"DOB: "_PSDOB
.W !!,CNT,?4,"Medication: ",LN,$E(LN,1,11),!!?4,"Outpatient Directions: ",LN,!?4
.W $E(LN,1,3),"SC",$E(LN,1,3),"NSC"," Quantity: _____ Days Supply _____ "
.W:'$G(PSORM) @LF W "Refills: 0 1 2 3 4 5 6 7 8 9 10 11"
.W !!?4,$E(LN,1,35)," ",$E(LN,1,14)," ",$E(LN,1,24)
.W !?4,"Provider's Signature",?40,"DEA #",?55,"Date/Time",!!,$E(LINE,1,$S('PSORM:80,1:IOM))
K LF Q
;
HD S FN=DFN S:'$D(PSORM) PSORM=1
D ELIG^PSOSD1,DEM^VADPT,INP^VADPT,ADD^VADPT,PID^VADPT S PSSN=VA("PID"),PSSN4="",ADDRFL=$S(+VAPA(9):"Temporary ",1:"")
I +VADM(6) S DOD(DFN)=$P(VADM(6),"^",2)
S PSNAME=$E(VADM(1),1,28),PSDOB=$P(VADM(3),"^",2) I $D(IOF),$G(PAGE)'=1 W @IOF
W "Action Rx Profile",?47,"Run Date: " S Y=DT D DT^DIO2 W ?71,"Page: "_PAGE S PAGE=PAGE+1,X=$$SITE^VASITE
W !,"Sorted by drug classification for Rx's currently active"_$S('PSDAYS:" only.",1:"") W:PSDAYS !,"and for those Rx's that have been inactive less than "_PSDAYS_" days."
;IHS/CIA/PLS - 01/28/04 - Removed references to VAMC
;W @$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
W @$S(PSORM:"?70",1:"!"),"Site: "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
I $P(VAIN(4),"^",2)]"",+$P($G(^PS(59.7,1,40.1)),"^") W !,"Outpatient prescriptions are discontinued 72 hours after admission.",!
W !?1,"Name : ",PSNAME W ?58,"Action Date: ________" W !?1,"DOB : "_PSDOB
W:ADDRFL]"" ?30,ADDRFL,! W ?30,"Address :"
I $G(ADDRFL)="" D CHECKBAI
W ?41,VAPA(1) W:VAPA(2)]"" !?41,VAPA(2) W:VAPA(3)]"" !?41,VAPA(3) W !?41,VAPA(4)_", "_$P(VAPA(5),"^",2)_" "_$S(VAPA(11)]"":$P(VAPA(11),"^",2),1:VAPA(6)),!?30,"Phone : "_VAPA(8)
I PSOBAR4 S X="S",X2=PSSN W @$S('PSORM:"!?30",1:"?$X+5") S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0
; IHS/CIA/PLS - 12/11/03 - Changed to call PCC Vitals
S (WT,HT)="" ;,X="GMRVUTL" X ^%ZOSF("TEST") I $T D
;.F GMRVSTR="WT","HT" S VM=GMRVSTR D EN6^GMRVUTL S @VM=X,$P(@VM,"^")=$E($P(@VM,"^"),4,5)_"/"_$E($P(@VM,"^"),6,7)_"/"_($E($P(@VM,"^"),1,3)+1700)
;.S X=$P(WT,"^",8),Y=$J(X/2.2,0,2),$P(WT,"^",9)=Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),$P(HT,"^",9)=Y
S WT=$$VITALF^APSPFUNC(DFN,"WT"),$P(WT,U,9)=$$VITCWT^APSPFUNC($P(WT,U,8))
S HT=$$VITALF^APSPFUNC(DFN,"HT"),$P(HT,U,9)=$$VITCHT^APSPFUNC($P(HT,U,8))
W !!,"WEIGHT(Kg): " W:+$P(WT,"^",8) $P(WT,"^",9)_" ("_$P(WT,"^")_")" W ?41,"HEIGHT(cm): " W:$P(HT,"^",8) $P(HT,"^",9)_" ("_$P(HT,"^")_")" K VM,WT,HT
;IHS/CIA/PLS - 01/28/04 - Removed VA FORM text.
;D GMRA^PSODEM W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!,"Instructions to the provider:",!,"A prescription blank (VA FORM 10-2577f) must be used for All Class II NARCOTICS."
D GMRA^PSODEM W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!,"Instructions to the provider:",!,"A prescription blank must be used for All Class II NARCOTICS."
S (ELN,LN,LINE)="",$P(LN,"_",53)="",$P(LINE,"-",132)=""
W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!?4,"OTHER MEDICATIONS:",!
Q
LM ;prints AP from listamn action
S X=$$SITE^VASITE,PSOINST=$P(X,"^",3) K X
K DIR S DIR("A")="Action or Informational (A or I): ",DIR("?",1)="Enter 'A' for action profile",DIR("?",2)=" 'I' for informational profile",DIR("?")=" 'E' to EXIT process",DIR("B")="A",DIR(0)="SAM^1:Action;0:Informational;E:Exit"
D ^DIR K DIR Q:Y="E"!($D(DIRUT)) S PSTYPE=Y,LM=1
I '$P($G(PSOSYS),"^",6) S PSOPOL=0 G ASK
K DIR S DIR("A")="Do you want generate a Polypharmacy report?: ",DIR("?",1)="Enter 'Y' to generate report",DIR("?",2)=" 'N' if you do not want the report",DIR("?")=" 'E' to EXIT process",DIR("B")="NO",DIR(0)="SA^1:YES;0:NO;E:Exit"
D ^DIR S PSOPOL=$S(Y:1,1:0) G:Y="E"!($D(DIRUT)) EXIT G:'PSOPOL ASK
K DIR S DIR("A")="Minimum Number of Active Prescriptions",DIR("B")=7,DIR(0)="N^1:100:0" D ^DIR S PSONUM=Y G:$D(DIRUT) EXIT
K DIR,DTOUT,DIRUT,DUOUT S DIR("A")="Do you want this Profile to print in 132 columns or 80 columns: ",DIR("B")="132",DIR(0)="SAM^1:132;8:80;E:Exit"
D ^DIR G:Y="E"!($D(DUOUT))!($D(DIRUT)) EXIT S PSORM=$S(Y=1:1,1:0) K DIR,X,Y
;PSO*7*240 Go to exit if DUOUT or DTOUT
ASK D DAYS G:($D(DUOUT))!($D(DTOUT)) EXIT S PRF=PSODFN_"," D DEV I $D(ZTSK) S VALMSG="Action Profile Queued to Printer."
D EXIT K LM
Q
;
CHECKBAI ;
N PSOBADR
S PSOBADR=$$BADADR^DGUTL3(DFN)
I 'PSOBADR W " " Q
W ?40,"** BAD ADDRESS INDICATED **",!
Q
;
PSOSD1 ;BHAM ISC/SAB/JMB - action or informational profile cont. ;29-May-2012 15:14;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**2,17,19,22,40,49,66,107,110,132,1005,233,258,240,320,326,1015**;DEC 1997;Build 62
+2 ;External reference to ^PS(59.7 is supported by DBIA 694
+3 ;
+4 ; Modified - IHS/CIA/PLS - 12/11/03 - Line HD+6 and HD+12
INIT NEW PSOPTLK
+1 SET PRF=""
FOR PSOI=0:0
SET DIC(0)="QEAM"
DO EN^PSOPATLK
SET Y=PSOPTLK
IF Y<1
QUIT
Begin DoDot:1
+2 SET PRF=PRF_+Y_","
SET DFN=+Y
DO DEM^VADPT
IF +VADM(6)
WRITE !,"Patient Expired on "_$PIECE(VADM(6),"^",2),!
SET DOD(DFN)=$PIECE(VADM(6),"^",2)
KILL DFN
+3 IF $LENGTH(PRF)>240
WRITE !,$CHAR(7),"MAX NUMBER OF PATIENTS HAS BEEN REACHED"
QUIT
End DoDot:1
+4 IF '$LENGTH(PRF)
QUIT
DO DAYS
IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO EXIT^PSOSD
DEV NEW PSOBARS,PSOBAR0,PSOBAR1
KILL %ZIS,IOP,ZTSK,ZTQUEUED
SET PSOION=ION
SET %ZIS="QM"
SET %ZIS("B")=""
SET %ZIS("A")=$SELECT(PSTYPE:"Select a Printer: ",1:"DEVICE: ")
DO ^%ZIS
KILL %ZIS
IF POP
SET IOP=PSOION
DO ^%ZIS
KILL IOP,PSOION
GOTO EXIT
+1 IF $EXTRACT(IOST)["C"
IF PSTYPE
DO ^%ZISC
WRITE $CHAR(7),!!,"Action Profiles MUST BE SENT TO A PRINTER !!",!,"ONLY INFORMATIONAL PROFILES ARE ALLOWED TO PRINT TO SCREEN !!",!
GOTO DEV
+2 SET PSOIOS=IOS
DO DEVBAR^PSOBMST
SET PSOBAR2=PSOBAR0
SET PSOBAR3=PSOBAR1
+3 SET PSOBAR4=$GET(PSOBAR3)]""&($GET(PSOBAR2)]"")&(+$PIECE($GET(PSOPAR),"^"))
+4 KILL PSOION
IF $DATA(IO("Q"))
SET ZTDESC="Outpatient Pharmacy Action Profile"
SET ZTRTN="START^PSOSD1"
SET ZTSAVE("ZTREQ")="@"
Begin DoDot:1
+5 FOR G="PSORM","PSOPOL","PSONUM","PSOSYS","PSOINST","PSOBAR3","PSOBAR4","PSOBAR2","PSOPAR","PSOPAR7","PRF","PSDAYS","PSDATE","PSTYPE","PSOSITE","PSDATE","PSDAY"
IF $DATA(@G)
SET ZTSAVE(G)=""
+6 SET ZTSAVE("DOD*")=""
SET ZTSAVE("PSOBAR*")=""
DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"Report Queued to Print !!",!
IF '$GET(LM)
KILL ZTSK,IO("Q")
End DoDot:1
DO EXIT
IF $GET(LM)
QUIT
GOTO ^PSOSD
+7 DO START
IF '$GET(LM)
GOTO ^PSOSD
+8 QUIT
START USE IO
SET PSTYPE=$SELECT($DATA(PSTYPE):PSTYPE,1:0)
SET $PIECE(LINE,"-",132)="-"
+1 FOR PSIX=1:1
SET DFN=$PIECE(PRF,",",PSIX)
IF DFN']""
GOTO EXIT
DO ELIG
SET PAGE=1
Begin DoDot:1
+2 DO PAT^PSOSD
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
Begin DoDot:2
+3 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
SET PSQFLG=0
DO ^PSOSD3
DO NVA^PSOSD3
DO EN^PSORMRXP(DFN)
End DoDot:2
IF PSQFLG
QUIT
IF PSTYPE
DO RXPAD
DO ENSTUFF^PSODACT
End DoDot:1
IF $GET(PSQFLG)!($DATA(DTOUT))!($DATA(DUOUT))
GOTO EXIT
EXIT IF '$DATA(PSONOPG)
WRITE !
DO ^%ZISC
KILL DFN
+1 IF $DATA(PSONOPG)&('$DATA(ORVP))
WRITE @IOF
+2 KILL ^TMP($JOB,"PRF"),^("ACT"),ADDR,ADDRFL,CLASS,CNDT,CNT,DRUG,CLAPP,HDFL,I,II,J,L,LINE,P,PAGE,PSDOB,PSIIX,PSNAME,PSOI,PSQFLG,PSSN,DFN,PSIX,PAGE,PGM,LINE,PRF,PSTYPE,PSDATE,PSDAYS,VAL,VAR,RX,RX0,RX3,RX2,ST,ST0,PSDAY,RF,RFS,PSOBAR3,PSOBAR4,PSOBAR
2
+3 DO KVA^VADPT
KILL DOD,FILL,DIC,PSCNT,PSDT,PCLASS,PHYS,ZCLASS,PSOPRINT,RXNODE,DIR,X1,X2,PSONUM,PSOPOLP,PSSN4
+4 QUIT
+5 ;
DAYS KILL DIR
SET DIR("A")="Profile Expiration/Discontinued Cutoff"
SET DIR("B")=120
SET DIR(0)="N^0:9999:0"
SET DIR("?",1)="Enter the number of days which will cut discontinued and expired Rx's from"
SET DIR("?")="the profile."
+1 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
SET PSDAYS=X
KILL DIR
SET X1=DT
SET X2=-PSDAYS
DO C^%DTC
SET (PSDATE,PSDAY)=X
+2 QUIT
+3 ;
DFN IF '$DATA(PSORM)
SET PSORM=1
+1 SET PSOIOS=IOS
DO DEVBAR^PSOBMST
SET PSOBAR2=PSOBAR0
SET PSOBAR3=PSOBAR1
+2 SET PSOBAR4=$GET(PSOBAR3)]""&($GET(PSOBAR2)]"")&(+$PIECE($GET(PSOPAR),"^"))
+3 IF $DATA(PSONOPG)&($GET(PSONOPG)'=2)
WRITE @IOF
IF '$GET(PSOSITE)
SET PSOSITE=$ORDER(^PS(59,0))
+4 SET PRF=DFN_","
IF '$GET(PSDAYS)
Begin DoDot:1
+5 SET PSDAYS=120
SET X1=DT
SET X2=-PSDAYS
DO C^%DTC
SET (PSDATE,PSDAY)=X
End DoDot:1
GOTO START
+6 QUIT
+7 ;
ELIG SET PSOPRINT=""
+1 DO ELIG^VADPT
+2 IF '$DATA(VAEL(4))
QUIT
+3 IF +VAEL(4)'=1
QUIT
+4 IF $DATA(VAEL(3))
IF +VAEL(3)=1
IF ($PIECE(VAEL(3),"^",2)<50)
SET PSOPRINT="SC NSC"
+5 DO KVAR^VADPT
+6 QUIT
+7 ;
RXPAD NEW K
IF $GET(DOD(DFN))]""
QUIT
DO HD
FOR CNT=1:1:4
SET LF="!?45"
Begin DoDot:1
+1 WRITE !?4,"Name: "_PSNAME,?58,"DOB: "_PSDOB
+2 WRITE !!,CNT,?4,"Medication: ",LN,$EXTRACT(LN,1,11),!!?4,"Outpatient Directions: ",LN,!?4
+3 WRITE $EXTRACT(LN,1,3),"SC",$EXTRACT(LN,1,3),"NSC"," Quantity: _____ Days Supply _____ "
+4 IF '$GET(PSORM)
WRITE @LF
WRITE "Refills: 0 1 2 3 4 5 6 7 8 9 10 11"
+5 WRITE !!?4,$EXTRACT(LN,1,35)," ",$EXTRACT(LN,1,14)," ",$EXTRACT(LN,1,24)
+6 WRITE !?4,"Provider's Signature",?40,"DEA #",?55,"Date/Time",!!,$EXTRACT(LINE,1,$SELECT('PSORM:80,1:IOM))
End DoDot:1
IF $Y+14>IOSL
QUIT
+7 KILL LF
QUIT
+8 ;
HD SET FN=DFN
IF '$DATA(PSORM)
SET PSORM=1
+1 DO ELIG^PSOSD1
DO DEM^VADPT
DO INP^VADPT
DO ADD^VADPT
DO PID^VADPT
SET PSSN=VA("PID")
SET PSSN4=""
SET ADDRFL=$SELECT(+VAPA(9):"Temporary ",1:"")
+2 IF +VADM(6)
SET DOD(DFN)=$PIECE(VADM(6),"^",2)
+3 SET PSNAME=$EXTRACT(VADM(1),1,28)
SET PSDOB=$PIECE(VADM(3),"^",2)
IF $DATA(IOF)
IF $GET(PAGE)'=1
WRITE @IOF
+4 WRITE "Action Rx Profile",?47,"Run Date: "
SET Y=DT
DO DT^DIO2
WRITE ?71,"Page: "_PAGE
SET PAGE=PAGE+1
SET X=$$SITE^VASITE
+5 WRITE !,"Sorted by drug classification for Rx's currently active"_$SELECT('PSDAYS:" only.",1:"")
IF PSDAYS
WRITE !,"and for those Rx's that have been inactive less than "_PSDAYS_" days."
+6 ;IHS/CIA/PLS - 01/28/04 - Removed references to VAMC
+7 ;W @$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
+8 WRITE @$SELECT(PSORM:"?70",1:"!"),"Site: "_$PIECE(X,"^",2)_" ("_$PIECE(X,"^",3)_")",!,$EXTRACT(LINE,1,$SELECT('PSORM:80,1:IOM)-1)
+9 IF $PIECE(VAIN(4),"^",2)]""
IF +$PIECE($GET(^PS(59.7,1,40.1)),"^")
WRITE !,"Outpatient prescriptions are discontinued 72 hours after admission.",!
+10 WRITE !?1,"Name : ",PSNAME
WRITE ?58,"Action Date: ________"
WRITE !?1,"DOB : "_PSDOB
+11 IF ADDRFL]""
WRITE ?30,ADDRFL,!
WRITE ?30,"Address :"
+12 IF $GET(ADDRFL)=""
DO CHECKBAI
+13 WRITE ?41,VAPA(1)
IF VAPA(2)]""
WRITE !?41,VAPA(2)
IF VAPA(3)]""
WRITE !?41,VAPA(3)
WRITE !?41,VAPA(4)_", "_$PIECE(VAPA(5),"^",2)_" "_$SELECT(VAPA(11)]"":$PIECE(VAPA(11),"^",2),1:VAPA(6)),!?30,"Phone : "_VAPA(8)
+14 IF PSOBAR4
SET X="S"
SET X2=PSSN
WRITE @$SELECT('PSORM:"!?30",1:"?$X+5")
SET X1=$X
WRITE @PSOBAR3,X2,@PSOBAR2,$CHAR(13)
SET $X=0
+15 ; IHS/CIA/PLS - 12/11/03 - Changed to call PCC Vitals
+16 ;,X="GMRVUTL" X ^%ZOSF("TEST") I $T D
SET (WT,HT)=""
+17 ;.F GMRVSTR="WT","HT" S VM=GMRVSTR D EN6^GMRVUTL S @VM=X,$P(@VM,"^")=$E($P(@VM,"^"),4,5)_"/"_$E($P(@VM,"^"),6,7)_"/"_($E($P(@VM,"^"),1,3)+1700)
+18 ;.S X=$P(WT,"^",8),Y=$J(X/2.2,0,2),$P(WT,"^",9)=Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),$P(HT,"^",9)=Y
+19 SET WT=$$VITALF^APSPFUNC(DFN,"WT")
SET $PIECE(WT,U,9)=$$VITCWT^APSPFUNC($PIECE(WT,U,8))
+20 SET HT=$$VITALF^APSPFUNC(DFN,"HT")
SET $PIECE(HT,U,9)=$$VITCHT^APSPFUNC($PIECE(HT,U,8))
+21 WRITE !!,"WEIGHT(Kg): "
IF +$PIECE(WT,"^",8)
WRITE $PIECE(WT,"^",9)_" ("_$PIECE(WT,"^")_")"
WRITE ?41,"HEIGHT(cm): "
IF $PIECE(HT,"^",8)
WRITE $PIECE(HT,"^",9)_" ("_$PIECE(HT,"^")_")"
KILL VM,WT,HT
+22 ;IHS/CIA/PLS - 01/28/04 - Removed VA FORM text.
+23 ;D GMRA^PSODEM W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!,"Instructions to the provider:",!,"A prescription blank (VA FORM 10-2577f) must be used for All Class II NARCOTICS."
+24 DO GMRA^PSODEM
WRITE !,$EXTRACT(LINE,1,$SELECT('PSORM:80,1:IOM)-1),!,"Instructions to the provider:",!,"A prescription blank must be used for All Class II NARCOTICS."
+25 SET (ELN,LN,LINE)=""
SET $PIECE(LN,"_",53)=""
SET $PIECE(LINE,"-",132)=""
+26 WRITE !,$EXTRACT(LINE,1,$SELECT('PSORM:80,1:IOM)-1),!?4,"OTHER MEDICATIONS:",!
+27 QUIT
LM ;prints AP from listamn action
+1 SET X=$$SITE^VASITE
SET PSOINST=$PIECE(X,"^",3)
KILL X
+2 KILL DIR
SET DIR("A")="Action or Informational (A or I): "
SET DIR("?",1)="Enter 'A' for action profile"
SET DIR("?",2)=" 'I' for informational profile"
SET DIR("?")=" 'E' to EXIT process"
SET DIR("B")="A"
SET DIR(0)="SAM^1:Action;0:Informational;E:Exit"
+3 DO ^DIR
KILL DIR
IF Y="E"!($DATA(DIRUT))
QUIT
SET PSTYPE=Y
SET LM=1
+4 IF '$PIECE($GET(PSOSYS),"^",6)
SET PSOPOL=0
GOTO ASK
+5 KILL DIR
SET DIR("A")="Do you want generate a Polypharmacy report?: "
SET DIR("?",1)="Enter 'Y' to generate report"
SET DIR("?",2)=" 'N' if you do not want the report"
SET DIR("?")=" 'E' to EXIT process"
SET DIR("B")="NO"
SET DIR(0)="SA^1:YES;0:NO;E:Exit"
+6 DO ^DIR
SET PSOPOL=$SELECT(Y:1,1:0)
IF Y="E"!($DATA(DIRUT))
GOTO EXIT
IF 'PSOPOL
GOTO ASK
+7 KILL DIR
SET DIR("A")="Minimum Number of Active Prescriptions"
SET DIR("B")=7
SET DIR(0)="N^1:100:0"
DO ^DIR
SET PSONUM=Y
IF $DATA(DIRUT)
GOTO EXIT
+8 KILL DIR,DTOUT,DIRUT,DUOUT
SET DIR("A")="Do you want this Profile to print in 132 columns or 80 columns: "
SET DIR("B")="132"
SET DIR(0)="SAM^1:132;8:80;E:Exit"
+9 DO ^DIR
IF Y="E"!($DATA(DUOUT))!($DATA(DIRUT))
GOTO EXIT
SET PSORM=$SELECT(Y=1:1,1:0)
KILL DIR,X,Y
+10 ;PSO*7*240 Go to exit if DUOUT or DTOUT
ASK DO DAYS
IF ($DATA(DUOUT))!($DATA(DTOUT))
GOTO EXIT
SET PRF=PSODFN_","
DO DEV
IF $DATA(ZTSK)
SET VALMSG="Action Profile Queued to Printer."
+1 DO EXIT
KILL LM
+2 QUIT
+3 ;
CHECKBAI ;
+1 NEW PSOBADR
+2 SET PSOBADR=$$BADADR^DGUTL3(DFN)
+3 IF 'PSOBADR
WRITE " "
QUIT
+4 WRITE ?40,"** BAD ADDRESS INDICATED **",!
+5 QUIT
+6 ;
