- PSOSD2 ;BHAM ISC/SAB - action or informational profile cont. ;29-May-2012 15:14;PLS
- ;;7.0;OUTPATIENT PHARMACY;**2,19,107,110,176,1005,233,258,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 HD1+28
- ; 12/15/03 - Line HD1+8
- ; 06/21/04 - Line 1+2
- 1 W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!
- W !,"Instructions to the provider:"
- ; IHS/CIA/PLS - 06/21/04 - Removed reference to VA Form
- ;W !," A. A prescription blank (VA FORM 10-2577f) must be used for the"
- W !," A. A prescription blank must be used for the"
- W !," following: 1) any new medication"
- W !," 2) any changes in dosage, direction or quantity"
- W !," 3) all class II narcotics."
- W !," B. To continue a medication as printed:"
- W !," 1. If ""Remaining Refills"" are sufficient to complete"
- W !," therapy or last until next scheduled clinic appointment,"
- W !," no action is required."
- W !," 2. If ""Remaining Refills"" are not sufficient to complete"
- W !," therapy or last until next scheduled clinic appointment,"
- W !," sign ""RENEW/MD"" line, enter VA# and date, and circle"
- W !," total number of refills needed. This action creates a"
- W !," new prescription with refills as indicated."
- W !," C. To discontinue a medication, sign DISCONTINUE/MD line and enter VA# and",@$S(PSORM:"?$X+1",1:"!?6"),"date."
- W !," D. Any medications not acted upon will continue to be available"
- W !," to the patient until all refills are used or until expiration."
- W !!," NOTE: '(R)' indicates a fill was returned to stock."
- Q
- ;
- HD S:'$D(PSORM) PSORM=1 N K S FN=DFN
- D ELIG^PSOSD1,DEM^VADPT,INP^VADPT,ADD^VADPT,PID^VADPT S PSSN=VA("PID"),ADDRFL=$S(+VAPA(9):"Temporary ",1:"")
- I $G(^TMP($J,DFN)),$D(CLINICX) D ^PSOSDP
- S PSNAME=$E(VADM(1),1,28),PSDOB=$P(VADM(3),"^",2)
- I '$D(PSOBAR0)!('$D(PSOBAR1)) S PSOIOS=IOS D DEVBAR^PSOBMST
- S PSOBAR2=PSOBAR0,PSOBAR3=PSOBAR1
- S PSOBAR4=$G(PSOBAR3)]""&($G(PSOBAR2)]"")&(+$P($G(PSOPAR),"^"))
- HD1 S RXCNT=0 I $E(IOST)="C",'PSTYPE K DIR S DIR(0)="E",DIR("A")="Press Return to Continue or ""^"" to Exit" D ^DIR Q:$D(DTOUT)!($D(DUOUT))
- I $D(IOF) W @IOF
- U IO
- W $S(PSTYPE:"Action",1:"Informational")_" Rx Profile",?47,"Run Date: " S Y=DT D DT^DIO2 W ?71,"Page: "_PAGE
- 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."
- S X=$$SITE^VASITE
- ;W @$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
- ; IHS/CIA/PLS - 12/15/03 - Changed to display PSO Site
- W @$S(PSORM:"?70",1:"!"),"Site: "_$P($G(^PS(59,PSOSITE,0)),U),!,$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.",!
- I $D(CLINICX) W !?1,"Clinic: ",$E(CLINICX,1,28),?45,"Date/Time: " S Y=CLDT D DT^DIO2
- W !?1,"Name : ",PSNAME W:PSTYPE ?58,"Action Date: ________" W !?1,"DOB : "_PSDOB
- W:ADDRFL]"" ?30,ADDRFL,! W ?30,"Address :"
- I $G(ADDRFL)="" D CHECKBAI^PSOSD1
- 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
- W:$G(DOD(DFN))]"" ?1,"**** Date of Death: "_DOD(DFN)_" ****",!
- D:'$D(HDFL)
- .K DIRUT,DIR,DUOUT,DTOUT D:'$G(CLAPP) RE^PSODEM Q:$D(DIRUT)
- .I $Y+15>IOSL,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR,DUOUT,DTOUT
- .Q:$D(DIRUT)
- .K ^UTILITY("VASD",$J),VASD S VASD("F")=DT,VASD("T")=9999999,VASD("W")="123456789" D:$G(DFN)&('$G(CLAPP)) SDA^VADPT K VASD I '$G(CLAPP)&($D(^UTILITY("VASD",$J))) D S CLAPP=1 D HD:$G(^TMP($J,DFN))'<$G(PSONUM)&($G(PSOPOL))
- ..W:$E(IOST)="C" @IOF
- ..W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
- ..S FA=DT W !!,"Pending Outpatient Clinic Appointments:"
- ..F PSOACPP=0:0 S PSOACPP=$O(^UTILITY("VASD",$J,PSOACPP)) Q:'PSOACPP S PSOACPPE=$G(^UTILITY("VASD",$J,PSOACPP,"E")),PSOACPPI=$G(^("I")) W !?11,$P(PSOACPPE,"^"),?35,$P(PSOACPPE,"^",2) D CAPP
- ..I $E(IOST)="C" K DIR,DIRUT,DTOUT S DIR(0)="E" D ^DIR K DIR
- .E D:$G(PAGE)>1&('$G(PSOPOL))
- ..; IHS/CIA/PLS - 12/11/03 - Changed to retrieve 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
- D:$D(DIRUT) KLCL Q:$D(DIRUT) S PAGE=PAGE+1 I $D(^UTILITY("VASD",$J)),PAGE=2!($G(PSOPOLP)) D KLCL S PSOPOLP=0 D HD Q
- D KLCL I PSTYPE,'$D(HDFL) D 1 S HDFL=""
- W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1),!,"Medication/Supply" Q:'PSORM
- W ?74,"Rx#",?85,"Status",?98,"Expiration",?110,"Provider",!,?101,"Date"
- Q
- ;
- CAPP ;
- K X S X2=DT,X1=$P($P($G(PSOACPPI),"^"),".") I $G(X1) D ^%DTC
- W $S($P(PSOACPPI,"^",3)["C":" *** Canceled ***",1:" ("_$G(X)_" days)")
- Q
- PSRENW D:'$G(PSODTCUT) CUTDATE^PSOFUNC I $P(RX2,"^",6)<PSODTCUT S PSRENW=0 G LN
- I $E($P(RX0,"^",15))="D",$P(RX3,"^",5)<PSODTCUT,$P(^PSRX(RXNO,"STA"),"^")=12 S PSRENW=0 G LN
- I $E($P(RX0,"^",15))="D",$P(^PSRX(RXNO,"STA"),"^")'=12 S PSRENW=0
- LN S CS=0 F DEA=1:1 Q:$E(PSODEA,DEA)="" I $E(+PSODEA,DEA)>2,$E(+PSODEA,DEA)<6 S CS=1
- K DEA,PSODEA Q
- KLCL K ^UTILITY("VASD",$J),PSOACPPI,PSOACPPE,PSOACPP Q
- PSOSD2 ;BHAM ISC/SAB - action or informational profile cont. ;29-May-2012 15:14;PLS
- +1 ;;7.0;OUTPATIENT PHARMACY;**2,19,107,110,176,1005,233,258,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 HD1+28
- +5 ; 12/15/03 - Line HD1+8
- +6 ; 06/21/04 - Line 1+2
- 1 WRITE !,$EXTRACT(LINE,1,$SELECT('PSORM:80,1:IOM)-1),!
- +1 WRITE !,"Instructions to the provider:"
- +2 ; IHS/CIA/PLS - 06/21/04 - Removed reference to VA Form
- +3 ;W !," A. A prescription blank (VA FORM 10-2577f) must be used for the"
- +4 WRITE !," A. A prescription blank must be used for the"
- +5 WRITE !," following: 1) any new medication"
- +6 WRITE !," 2) any changes in dosage, direction or quantity"
- +7 WRITE !," 3) all class II narcotics."
- +8 WRITE !," B. To continue a medication as printed:"
- +9 WRITE !," 1. If ""Remaining Refills"" are sufficient to complete"
- +10 WRITE !," therapy or last until next scheduled clinic appointment,"
- +11 WRITE !," no action is required."
- +12 WRITE !," 2. If ""Remaining Refills"" are not sufficient to complete"
- +13 WRITE !," therapy or last until next scheduled clinic appointment,"
- +14 WRITE !," sign ""RENEW/MD"" line, enter VA# and date, and circle"
- +15 WRITE !," total number of refills needed. This action creates a"
- +16 WRITE !," new prescription with refills as indicated."
- +17 WRITE !," C. To discontinue a medication, sign DISCONTINUE/MD line and enter VA# and",@$SELECT(PSORM:"?$X+1",1:"!?6"),"date."
- +18 WRITE !," D. Any medications not acted upon will continue to be available"
- +19 WRITE !," to the patient until all refills are used or until expiration."
- +20 WRITE !!," NOTE: '(R)' indicates a fill was returned to stock."
- +21 QUIT
- +22 ;
- HD IF '$DATA(PSORM)
- SET PSORM=1
- NEW K
- SET FN=DFN
- +1 DO ELIG^PSOSD1
- DO DEM^VADPT
- DO INP^VADPT
- DO ADD^VADPT
- DO PID^VADPT
- SET PSSN=VA("PID")
- SET ADDRFL=$SELECT(+VAPA(9):"Temporary ",1:"")
- +2 IF $GET(^TMP($JOB,DFN))
- IF $DATA(CLINICX)
- DO ^PSOSDP
- +3 SET PSNAME=$EXTRACT(VADM(1),1,28)
- SET PSDOB=$PIECE(VADM(3),"^",2)
- +4 IF '$DATA(PSOBAR0)!('$DATA(PSOBAR1))
- SET PSOIOS=IOS
- DO DEVBAR^PSOBMST
- +5 SET PSOBAR2=PSOBAR0
- SET PSOBAR3=PSOBAR1
- +6 SET PSOBAR4=$GET(PSOBAR3)]""&($GET(PSOBAR2)]"")&(+$PIECE($GET(PSOPAR),"^"))
- HD1 SET RXCNT=0
- IF $EXTRACT(IOST)="C"
- IF 'PSTYPE
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to Continue or ""^"" to Exit"
- DO ^DIR
- IF $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +1 IF $DATA(IOF)
- WRITE @IOF
- +2 USE IO
- +3 WRITE $SELECT(PSTYPE:"Action",1:"Informational")_" Rx Profile",?47,"Run Date: "
- SET Y=DT
- DO DT^DIO2
- WRITE ?71,"Page: "_PAGE
- +4 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."
- +5 SET X=$$SITE^VASITE
- +6 ;W @$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
- +7 ; IHS/CIA/PLS - 12/15/03 - Changed to display PSO Site
- +8 WRITE @$SELECT(PSORM:"?70",1:"!"),"Site: "_$PIECE($GET(^PS(59,PSOSITE,0)),U),!,$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 IF $DATA(CLINICX)
- WRITE !?1,"Clinic: ",$EXTRACT(CLINICX,1,28),?45,"Date/Time: "
- SET Y=CLDT
- DO DT^DIO2
- +11 WRITE !?1,"Name : ",PSNAME
- IF PSTYPE
- WRITE ?58,"Action Date: ________"
- WRITE !?1,"DOB : "_PSDOB
- +12 IF ADDRFL]""
- WRITE ?30,ADDRFL,!
- WRITE ?30,"Address :"
- +13 IF $GET(ADDRFL)=""
- DO CHECKBAI^PSOSD1
- +14 WRITE ?41,VAPA(1)
- IF VAPA(2)]""
- WRITE !?41,VAPA(2)
- IF VAPA(3)]""
- WRITE !?41,VAPA(3)
- +15 WRITE !?41,VAPA(4)_", "_$PIECE(VAPA(5),"^",2)_" "_$SELECT(VAPA(11)]"":$PIECE(VAPA(11),"^",2),1:VAPA(6)),!?30,"Phone : "_VAPA(8)
- +16 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
- +17 IF $GET(DOD(DFN))]""
- WRITE ?1,"**** Date of Death: "_DOD(DFN)_" ****",!
- +18 IF '$DATA(HDFL)
- Begin DoDot:1
- +19 KILL DIRUT,DIR,DUOUT,DTOUT
- IF '$GET(CLAPP)
- DO RE^PSODEM
- IF $DATA(DIRUT)
- QUIT
- +20 IF $Y+15>IOSL
- IF $EXTRACT(IOST)="C"
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR,DUOUT,DTOUT
- +21 IF $DATA(DIRUT)
- QUIT
- +22 KILL ^UTILITY("VASD",$JOB),VASD
- SET VASD("F")=DT
- SET VASD("T")=9999999
- SET VASD("W")="123456789"
- IF $GET(DFN)&('$GET(CLAPP))
- DO SDA^VADPT
- KILL VASD
- IF '$GET(CLAPP)&($DATA(^UTILITY("VASD",$JOB)))
- Begin DoDot:2
- +23 IF $EXTRACT(IOST)="C"
- WRITE @IOF
- +24 WRITE !,$EXTRACT(LINE,1,$SELECT('PSORM:80,1:IOM)-1)
- +25 SET FA=DT
- WRITE !!,"Pending Outpatient Clinic Appointments:"
- +26 FOR PSOACPP=0:0
- SET PSOACPP=$ORDER(^UTILITY("VASD",$JOB,PSOACPP))
- IF 'PSOACPP
- QUIT
- SET PSOACPPE=$GET(^UTILITY("VASD",$JOB,PSOACPP,"E"))
- SET PSOACPPI=$GET(^("I"))
- WRITE !?11,$PIECE(PSOACPPE,"^"),?35,$PIECE(PSOACPPE,"^",2)
- DO CAPP
- +27 IF $EXTRACT(IOST)="C"
- KILL DIR,DIRUT,DTOUT
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- End DoDot:2
- SET CLAPP=1
- IF $GET(^TMP($JOB,DFN))'<$GET(PSONUM)&($GET(PSOPOL))
- DO HD
- +28 IF '$TEST
- IF $GET(PAGE)>1&('$GET(PSOPOL))
- Begin DoDot:2
- +29 ; IHS/CIA/PLS - 12/11/03 - Changed to retrieve PCC Vitals
- +30 ;,X="GMRVUTL" X ^%ZOSF("TEST") I $T D
- SET (WT,HT)=""
- +31 ;.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)
- +32 ;.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
- +33 SET WT=$$VITALF^APSPFUNC(DFN,"WT")
- SET $PIECE(WT,U,9)=$$VITCWT^APSPFUNC($PIECE(WT,U,8))
- +34 SET HT=$$VITALF^APSPFUNC(DFN,"HT")
- SET $PIECE(HT,U,9)=$$VITCHT^APSPFUNC($PIECE(HT,U,8))
- +35 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
- End DoDot:2
- End DoDot:1
- +36 IF $DATA(DIRUT)
- DO KLCL
- IF $DATA(DIRUT)
- QUIT
- SET PAGE=PAGE+1
- IF $DATA(^UTILITY("VASD",$JOB))
- IF PAGE=2!($GET(PSOPOLP))
- DO KLCL
- SET PSOPOLP=0
- DO HD
- QUIT
- +37 DO KLCL
- IF PSTYPE
- IF '$DATA(HDFL)
- DO 1
- SET HDFL=""
- +38 WRITE !,$EXTRACT(LINE,1,$SELECT('PSORM:80,1:IOM)-1),!,"Medication/Supply"
- IF 'PSORM
- QUIT
- +39 WRITE ?74,"Rx#",?85,"Status",?98,"Expiration",?110,"Provider",!,?101,"Date"
- +40 QUIT
- +41 ;
- CAPP ;
- +1 KILL X
- SET X2=DT
- SET X1=$PIECE($PIECE($GET(PSOACPPI),"^"),".")
- IF $GET(X1)
- DO ^%DTC
- +2 WRITE $SELECT($PIECE(PSOACPPI,"^",3)["C":" *** Canceled ***",1:" ("_$GET(X)_" days)")
- +3 QUIT
- PSRENW IF '$GET(PSODTCUT)
- DO CUTDATE^PSOFUNC
- IF $PIECE(RX2,"^",6)<PSODTCUT
- SET PSRENW=0
- GOTO LN
- +1 IF $EXTRACT($PIECE(RX0,"^",15))="D"
- IF $PIECE(RX3,"^",5)<PSODTCUT
- IF $PIECE(^PSRX(RXNO,"STA"),"^")=12
- SET PSRENW=0
- GOTO LN
- +2 IF $EXTRACT($PIECE(RX0,"^",15))="D"
- IF $PIECE(^PSRX(RXNO,"STA"),"^")'=12
- SET PSRENW=0
- LN SET CS=0
- FOR DEA=1:1
- IF $EXTRACT(PSODEA,DEA)=""
- QUIT
- IF $EXTRACT(+PSODEA,DEA)>2
- IF $EXTRACT(+PSODEA,DEA)<6
- SET CS=1
- +1 KILL DEA,PSODEA
- QUIT
- KLCL KILL ^UTILITY("VASD",$JOB),PSOACPPI,PSOACPPE,PSOACPP
- QUIT
