- PSJADT1 ;BIR/CML3-AUTO CANCEL/HOLD UTILITIES ;17 JAN 96 / 10:11 AM
- ;;5.0; INPATIENT MEDICATIONS ;**30,37,51,83**;16 DEC 97
- ;
- ; Reference to ^PS(55 is supported by DBIA# 2191.
- ; Reference to ^PS(59.7 is supported by DBIA# 2181.
- ;
- ENUW ; update ward and treating specialty
- D INP^VADPT,NOW^%DTC F Q1=%:0 S Q1=$O(^PS(55,PSGP,5,"AUS",Q1)) Q:'Q1 F Q2=0:0 S Q2=$O(^PS(55,PSGP,5,"AUS",Q1,Q2)) Q:'Q2 D
- .I $D(^PS(55,PSGP,5,Q2,0)) S $P(^(0),"^",23)=+VAIN(4),^PS(55,"AUE",PSGP,Q2)=""
- F ON=0:0 S ON=$O(^PS(55,PSGP,"IV",ON)) Q:'ON I $D(^(ON,0)) S $P(^(0),"^",22)=+VAIN(4)
- Q
- ;
- ENHOLD(PSGOEHA,PSJDEL,PSJPAD,PSGALO) ;
- ; place orders on/off hold
- S X=PSGOEHA W:'$D(DGQUIET) !,"...",$S(X:"plac",1:"tak"),"ing Inpatient Medication orders o",$S(X:"n",1:"ff")," of hold..."
- D NOW^%DTC S PSGDT=+$E(%,1,12),PSGOEHA='PSGOEHA D ENACH^PSGOEHA
- S DFN=PSGP,PSIVNST="H" I 'PSGOEHA D ^PSIVHLD
- I PSGOEHA D START^PSIVHLD
- I 'PSGOEHA S X=PSJDEL,X=$S(X=3:2,X=22:2,X=26:2,1:1),$P(PSJPIND,"^",7)=2,$P(PSJPIND,"^",10)="Transferred "_$P("A^Una",U,X)_"uthorized Absence" Q
- S $P(PSJPIND,"^",7)="",$P(PSJPIND,"^",10)="" G ENUW
- ;
- ENDEL(DFN,DGPMP,PSJTMT,PSJDEL) ;
- ;Undo mvmt action if movement is deleted.
- N VAIP S VAIP("D")=+DGPMP D IN5^VADPT Q:VAIP(16)
- ; Add call to PSJADT0 to dc active/non-verified orders for cancelled admissions.
- I PSJDEL=1 D Q
- . S PSJPAD=+VAIP(13,1),PSGALO=1035
- . N VAIP D IN5^VADPT Q:+VAIP(13,1)>PSJPAD
- . D ENDC^PSJADT0
- I PSJDEL=3 D ENUNDC^PSJADT0(+DGPMP,DFN,VAIP(5),18540) Q
- I PSJDEL=6 D ENUNDC^PSJADT0(+DGPMP,DFN,VAIP(5),18550) Q
- I PSJTMT=4 D ENUNDC^PSJADT0(+DGPMP,DFN,VAIP(5),18550) Q
- I PSJTMT<4 D
- .I $P($G(^PS(55,DFN,5.1)),U,7),$P(^(5.1),U,10)["Transferred" D ENHOLD(0,PSJDEL,+DGPMP,8090)
- .D ENUNDC^PSJADT0(+DGPMP,DFN,VAIP(5),18550)
- I PSJTMT>21,(PSJTMT<27) S X=PSJTMT I $P($G(^PS(59.7,1,22,+VAIP(5),0)),U,$S(X=22!(X=26):4,X=23:2,1:3)) D ENHOLD(1,X,+DGPMP,8590)
- Q
-
- PSJADT1 ;BIR/CML3-AUTO CANCEL/HOLD UTILITIES ;17 JAN 96 / 10:11 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**30,37,51,83**;16 DEC 97
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +4 ; Reference to ^PS(59.7 is supported by DBIA# 2181.
- +5 ;
- ENUW ; update ward and treating specialty
- +1 DO INP^VADPT
- DO NOW^%DTC
- FOR Q1=%:0
- SET Q1=$ORDER(^PS(55,PSGP,5,"AUS",Q1))
- IF 'Q1
- QUIT
- FOR Q2=0:0
- SET Q2=$ORDER(^PS(55,PSGP,5,"AUS",Q1,Q2))
- IF 'Q2
- QUIT
- Begin DoDot:1
- +2 IF $DATA(^PS(55,PSGP,5,Q2,0))
- SET $PIECE(^(0),"^",23)=+VAIN(4)
- SET ^PS(55,"AUE",PSGP,Q2)=""
- End DoDot:1
- +3 FOR ON=0:0
- SET ON=$ORDER(^PS(55,PSGP,"IV",ON))
- IF 'ON
- QUIT
- IF $DATA(^(ON,0))
- SET $PIECE(^(0),"^",22)=+VAIN(4)
- +4 QUIT
- +5 ;
- ENHOLD(PSGOEHA,PSJDEL,PSJPAD,PSGALO) ;
- +1 ; place orders on/off hold
- +2 SET X=PSGOEHA
- IF '$DATA(DGQUIET)
- WRITE !,"...",$SELECT(X:"plac",1:"tak"),"ing Inpatient Medication orders o",$SELECT(X:"n",1:"ff")," of hold..."
- +3 DO NOW^%DTC
- SET PSGDT=+$EXTRACT(%,1,12)
- SET PSGOEHA='PSGOEHA
- DO ENACH^PSGOEHA
- +4 SET DFN=PSGP
- SET PSIVNST="H"
- IF 'PSGOEHA
- DO ^PSIVHLD
- +5 IF PSGOEHA
- DO START^PSIVHLD
- +6 IF 'PSGOEHA
- SET X=PSJDEL
- SET X=$SELECT(X=3:2,X=22:2,X=26:2,1:1)
- SET $PIECE(PSJPIND,"^",7)=2
- SET $PIECE(PSJPIND,"^",10)="Transferred "_$PIECE("A^Una",U,X)_"uthorized Absence"
- QUIT
- +7 SET $PIECE(PSJPIND,"^",7)=""
- SET $PIECE(PSJPIND,"^",10)=""
- GOTO ENUW
- +8 ;
- ENDEL(DFN,DGPMP,PSJTMT,PSJDEL) ;
- +1 ;Undo mvmt action if movement is deleted.
- +2 NEW VAIP
- SET VAIP("D")=+DGPMP
- DO IN5^VADPT
- IF VAIP(16)
- QUIT
- +3 ; Add call to PSJADT0 to dc active/non-verified orders for cancelled admissions.
- +4 IF PSJDEL=1
- Begin DoDot:1
- +5 SET PSJPAD=+VAIP(13,1)
- SET PSGALO=1035
- +6 NEW VAIP
- DO IN5^VADPT
- IF +VAIP(13,1)>PSJPAD
- QUIT
- +7 DO ENDC^PSJADT0
- End DoDot:1
- QUIT
- +8 IF PSJDEL=3
- DO ENUNDC^PSJADT0(+DGPMP,DFN,VAIP(5),18540)
- QUIT
- +9 IF PSJDEL=6
- DO ENUNDC^PSJADT0(+DGPMP,DFN,VAIP(5),18550)
- QUIT
- +10 IF PSJTMT=4
- DO ENUNDC^PSJADT0(+DGPMP,DFN,VAIP(5),18550)
- QUIT
- +11 IF PSJTMT<4
- Begin DoDot:1
- +12 IF $PIECE($GET(^PS(55,DFN,5.1)),U,7)
- IF $PIECE(^(5.1),U,10)["Transferred"
- DO ENHOLD(0,PSJDEL,+DGPMP,8090)
- +13 DO ENUNDC^PSJADT0(+DGPMP,DFN,VAIP(5),18550)
- End DoDot:1
- +14 IF PSJTMT>21
- IF (PSJTMT<27)
- SET X=PSJTMT
- IF $PIECE($GET(^PS(59.7,1,22,+VAIP(5),0)),U,$SELECT(X=22!(X=26):4,X=23:2,1:3))
- DO ENHOLD(1,X,+DGPMP,8590)
- +15 QUIT
- +16
- ***** ERRORS & WARNINGS IN PSJADT1 *****
- PSJADT1+1 S - 2nd line of routine violates the SAC.
