- PSJADT0 ;BIR/CML3,PR,MLM-AUTO DC/HOLD CANCEL ;11 Aug 98 / 8:25 AM
- ;;5.0;INPATIENT MEDICATIONS ;**17,111,112,135,181,274,390**;16 DEC 97;Build 7
- ;
- ;Reference to ^PS(55 supported by DBIA #2191.
- ;
- ENDC ; dc active orders first, then non-verified orders
- W:'$D(PSJQUIET)&'$D(DGQUIET) !,"...discontinuing Inpatient Medication orders..."
- S $P(PSJPIND,"^")=""
- D NOW^%DTC N PSJDCDT S (PSJDCDT,PSGDT)=+%,PSJSYSW0="" I PSJFW S PSJSYSW=$O(^PS(59.6,"B",PSJFW,0)) S:PSJSYSW PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
- I PSGALO=1010!(PSGALO=1030)!(PSGALO=1050) D AUDDD
- D ENUNM^PSGOU S PSGALR=10,DIE="^PS(55,"_PSGP_",5," S:PSJFW PSGTOL=1,PSGUOW=PSJFW,PSGTOO=1
- F PSJS=PSGDT:0 S PSJS=$O(^PS(55,PSGP,5,"AUS",PSJS)) Q:'PSJS F PSJDA=0:0 S PSJDA=$O(^PS(55,PSGP,5,"AUS",PSJS,PSJDA)) Q:'PSJDA D
- .Q:'$$DCIMO(PSGP,PSJDA,"U")
- .;first naked reference below refers to the full global reference to the right of the = sign (inside the $S)
- .K DA S DA(1)=PSGP,DA=PSJDA,PSGAL("C")=0,$P(^(2),"^",3)=$S($D(^PS(55,PSGP,5,DA,2)):$P(^(2),"^",4),1:"")
- .D ^PSGAL5
- .K TMP
- .S TMP(55.06,""_PSJDA_","_PSGP_","_"",28)="D"
- .S TMP(55.06,""_PSJDA_","_PSGP_","_"",136)=$S(PSGALO=1010:"DD",1:"DA")
- .D FILE^DIE("","TMP")
- .K TMP
- .S TMP(55.06,""_PSJDA_","_PSGP_","_"",34)=PSJDCDT
- .S TMP(55.06,""_PSJDA_","_PSGP_","_"",49)=1
- .D FILE^DIE("","TMP")
- .K TMP
- .D EN1^PSJHL2(PSGP,"OD",PSJDA_"U","AUTO DC")
- .I PSGALO'=1050 S DA=PSJDA,^PS(55,"AUE",PSGP,DA)="" I $P(PSJSYSW0,"^",15),(PSGALO'<1060) S $P(^PS(55,PSGP,5,PSJDA,7),"^",1,2)=PSJDCDT_"^D" D ENL^PSGVDS
- S PSGTOO=2 F PSJDA=0:0 S PSJDA=$O(^PS(53.1,"AC",PSGP,PSJDA)) Q:'PSJDA D
- .Q:'$$DCIMO(PSGP,PSJDA,"P")
- .I PSGALO'<1060,$P(PSJSYSW0,U,15),$P($G(^PS(53.1,PSJDA,0)),U,9)="N" K DA D ENLBL^PSIVOPT(PSGTOL,PSGUOW,DFN,2,+PSJDA,"AD")
- .K DA S DA=PSJDA D I $P($G(^PS(53.1,DA,0)),"^",21) D EN1^PSJHL2(PSGP,"OC",PSJDA_"P","AUTO DC")
- ..K TMP
- ..S TMP(53.1,""_PSJDA_","_"",28)="D"
- ..S TMP(53.1,""_PSJDA_","_"",42)=1
- ..D FILE^DIE("","TMP")
- ..K TMP
- ;
- ENIV ;
- S DFN=PSGP F PSJIVON=0:0 S PSJIVON=$O(^PS(55,DFN,"IV",PSJIVON)) Q:'PSJIVON S Y=$G(^(PSJIVON,0)) I "PDEN"'[$P(Y,U,17) S P(17)=$P(Y,U,17),P(3)=$P(Y,U,3) D DC
- Q
- DC ;
- Q:'$$DCIMO(DFN,PSJIVON,"V")
- S (ON,ON55)=PSJIVON_"V" D NOW^%DTC I P(17)="H",P(3)<% D D EXPIR^PSIVOE Q
- .K TMP
- .S TMP(55.01,""_+ON_","_DFN_","_"",100)="E"
- .D FILE^DIE("","TMP")
- .K TMP
- K PSIVALT S PSIVAC="AD",PSIVALCK="STOP",PSIVREA="D",PSIVAL=$S('+$G(PSGALO):$G(PSIVRES),1:$P($G(^PS(53.3,+PSGALO,0)),U)) D D1^PSIVOPT2,LOG^PSIVORAL
- K TMP
- S TMP(55.01,""_+ON_","_DFN_","_"",157)=$S($G(PSGALO)=1010:"DD",1:"DA")
- S TMP(55.01,""_+ON_","_DFN_","_"",.03)=PSJDCDT
- S TMP(55.01,""_+ON_","_DFN_","_"",121)=1
- D FILE^DIE("","TMP")
- K TMP
- D EN1^PSJHL2(DFN,"OD",+ON_"V","AUTO DC")
- S PSJIVDCF=1
- Q
- ;
- SIVDIE ; Setup DIE,DA for IV
- K DA,DIE,DR S DA=+ON,DA(1)=DFN,DIE="^PS(55,"_DFN_",""IV"","
- Q
- ;
- AUDDD ; set up orders for discharge report and purging
- S DIS=+VAIP(17,1) I $S('DIS:1,1:$D(^PS(55,"AUDDD",DIS,PSGP))) Q
- S X=$$EN^PSGCT(+VAIP(13,1),-1)
- F Q=X:0 S Q=$O(^PS(55,PSGP,5,"AUS",Q)) Q:'Q F QQ=0:0 S QQ=$O(^PS(55,PSGP,5,"AUS",Q,QQ)) Q:'QQ I $S($D(^PS(55,PSGP,5,QQ,0)):'$P(^(0),"^",20),1:1) S $P(^(0),"^",20)=DIS,^PS(55,"AUDDD",DIS,PSGP,QQ)=""
- Q
- ;
- ENHE ; status from hold to expired
- D NOW^%DTC S PSGDT=+$E(%,1,12),DIE="^PS(55,"_PSGP_",5,"
- F PSJS=+PSJPAD:0 S PSJS=$O(^PS(55,PSGP,5,"AUS",PSJS)) Q:'PSJS Q:PSJS>PSGDT F PSJDA=0:0 S PSJDA=$O(^PS(55,PSGP,5,"AUS",PSJS,PSJDA)) Q:'PSJDA K DA S DA(1)=PSGP,DA=PSJDA I $D(^PS(55,PSGP,5,DA,0)),$P(^(0),"^",9)="H" S DR="28////E" D ^DIE
- Q
- ;
- ENUNDC(PSJDCDT,PSGP,PSJUOW,PSGALO) ; Auto-reinstate orders DC'ed due to a patient movement.
- N PSJSYSW0 D NOW^%DTC S PSJUNDC=1,PSGDT=%,PSJFIRST='$D(PSJQUIET),PSJSYSW0=$G(^PS(59.6,+$O(^PS(59.6,"B",+PSJUOW,0)),0))
- S PSJS=$O(^PS(55,PSGP,5,"AUS",PSJDCDT-.0002)) F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,5,"AUS",+PSJS,PSGORD)) Q:'PSGORD D
- .I $P($G(^PS(55,PSGP,5,PSGORD,0)),U,9)["D",$P($G(^(4)),U,11) D DISREIN,ENRI^PSGOERI
- .S ^PS(55,"AUE",PSGP,PSGORD)=""
- ;
- S:PSJS="" PSJS=$O(^PS(55,PSGP,"IV","AIS",PSJDCDT-.0002))
- F PSGORD=0:0 S PSGORD=$O(^PS(55,PSGP,"IV","AIS",+PSJS,PSGORD)) Q:'PSGORD D
- .I $P($G(^PS(55,PSGP,"IV",PSGORD,0)),U,12),$P($G(^(2)),U,7)>PSGDT S P(3)=$P($G(^(0)),U,3) D DISREIN,ENARI^PSIVOPT(PSGP,PSGORD,+PSJUOW,PSGALO)
- I $D(^TMP("PSJUNDC")) S ^TMP("PSJUNDC",$J,DFN)=$P(^DPT(DFN,0),"^")_"^"_$G(^DPT(PSGP,.1))_"^"_PSGALO D ^PSJADT2
- ;
- ENKL ;
- F UW=0:0 S UW=$O(^PS(53.41,1,1,UW)) Q:'UW D I '$O(^PS(53.41,1,1,0)) K DA S DA=1,DIK="^PS(53.41," D ^DIK
- .F PSGP=0:0 S PSGP=$O(^PS(53.41,1,1,UW,1,PSGP)) Q:'PSGP D I '$O(^PS(53.41,1,1,UW,1,0)) K DA S DIK="^PS(53.41,1,1,",DA(1)=1,DA=UW D ^DIK
- ..F TO=0:0 S TO=$O(^PS(53.41,1,1,UW,1,PSGP,1,TO)) Q:'TO D I '$O(^PS(53.41,1,1,UW,1,PSGP,1,0)) K DA S DA(2)=1,DA(1)=UW,DA=PSGP,DIK="^PS(53.41,1,1,"_UW_",1," D ^DIK
- ...I '$O(^PS(53.41,1,1,UW,1,PSGP,1,TO,1,0)) K DA S DA(3)=1,DA(2)=UW,DA(1)=PSGP,DA=TO,DIK="^PS(53.41,1,1,"_UW_",1,"_PSGP_",1," D ^DIK
- K DA,DIK,P,PSGDT,PSGP,PSGORD,PSJS,PSJUNDC,TO,UW
- Q
- ;
- DISREIN ; Display reinstate msg. for first order.
- W:PSJFIRST&'$D(DGQUIET) !,"...reinstating Inpatient Medication orders..." S PSJFIRST=0
- Q
- ;
- DCIMO(DFN,ON,TYP) ; Check parameter before DC'ing clinic order
- N GLO,IMOND,A,CLINIC,APPT,B,C S GLO=$S(TYP="P":"^PS(53.1,",TYP="U":"^PS(55,"_DFN_",5,",TYP="V":"^PS(55,"_PSGP_",""IV"",",1:"") I TYP="" Q 1
- S IMOND=$S(TYP="P"!(TYP="V"):"""DSS""",TYP="U":8,1:"") I IMOND="" Q 1
- S GLO=GLO_+ON_","_IMOND_")",A=$G(@GLO),CLINIC=$P(A,"^"),APPT=$P(A,"^",2)
- Q:'$$CLINIC^PSJBCMA(A) 1
- I '$D(^PS(53.46,"B",CLINIC)) Q 1
- I $$GET1^DIQ(2,DFN,.351,"I") Q 1 ;p390 .351 Patient DATE OF DEATH
- S B=$O(^PS(53.46,"B",CLINIC,"")),C=+$P(^PS(53.46,B,0),"^",3) Q C
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJADT0 5760 printed Feb 18, 2025@23:32:30 Page 2
- PSJADT0 ;BIR/CML3,PR,MLM-AUTO DC/HOLD CANCEL ;11 Aug 98 / 8:25 AM
- +1 ;;5.0;INPATIENT MEDICATIONS ;**17,111,112,135,181,274,390**;16 DEC 97;Build 7
- +2 ;
- +3 ;Reference to ^PS(55 supported by DBIA #2191.
- +4 ;
- ENDC ; dc active orders first, then non-verified orders
- +1 if '$DATA(PSJQUIET)&'$DATA(DGQUIET)
- WRITE !,"...discontinuing Inpatient Medication orders..."
- +2 SET $PIECE(PSJPIND,"^")=""
- +3 DO NOW^%DTC
- NEW PSJDCDT
- SET (PSJDCDT,PSGDT)=+%
- SET PSJSYSW0=""
- IF PSJFW
- SET PSJSYSW=$ORDER(^PS(59.6,"B",PSJFW,0))
- if PSJSYSW
- SET PSJSYSW0=$GET(^PS(59.6,PSJSYSW,0))
- +4 IF PSGALO=1010!(PSGALO=1030)!(PSGALO=1050)
- DO AUDDD
- +5 DO ENUNM^PSGOU
- SET PSGALR=10
- SET DIE="^PS(55,"_PSGP_",5,"
- if PSJFW
- SET PSGTOL=1
- SET PSGUOW=PSJFW
- SET PSGTOO=1
- +6 FOR PSJS=PSGDT:0
- SET PSJS=$ORDER(^PS(55,PSGP,5,"AUS",PSJS))
- if 'PSJS
- QUIT
- FOR PSJDA=0:0
- SET PSJDA=$ORDER(^PS(55,PSGP,5,"AUS",PSJS,PSJDA))
- if 'PSJDA
- QUIT
- Begin DoDot:1
- +7 if '$$DCIMO(PSGP,PSJDA,"U")
- QUIT
- +8 ;first naked reference below refers to the full global reference to the right of the = sign (inside the $S)
- +9 KILL DA
- SET DA(1)=PSGP
- SET DA=PSJDA
- SET PSGAL("C")=0
- SET $PIECE(^(2),"^",3)=$SELECT($DATA(^PS(55,PSGP,5,DA,2)):$PIECE(^(2),"^",4),1:"")
- +10 DO ^PSGAL5
- +11 KILL TMP
- +12 SET TMP(55.06,""_PSJDA_","_PSGP_","_"",28)="D"
- +13 SET TMP(55.06,""_PSJDA_","_PSGP_","_"",136)=$SELECT(PSGALO=1010:"DD",1:"DA")
- +14 DO FILE^DIE("","TMP")
- +15 KILL TMP
- +16 SET TMP(55.06,""_PSJDA_","_PSGP_","_"",34)=PSJDCDT
- +17 SET TMP(55.06,""_PSJDA_","_PSGP_","_"",49)=1
- +18 DO FILE^DIE("","TMP")
- +19 KILL TMP
- +20 DO EN1^PSJHL2(PSGP,"OD",PSJDA_"U","AUTO DC")
- +21 IF PSGALO'=1050
- SET DA=PSJDA
- SET ^PS(55,"AUE",PSGP,DA)=""
- IF $PIECE(PSJSYSW0,"^",15)
- IF (PSGALO'<1060)
- SET $PIECE(^PS(55,PSGP,5,PSJDA,7),"^",1,2)=PSJDCDT_"^D"
- DO ENL^PSGVDS
- End DoDot:1
- +22 SET PSGTOO=2
- FOR PSJDA=0:0
- SET PSJDA=$ORDER(^PS(53.1,"AC",PSGP,PSJDA))
- if 'PSJDA
- QUIT
- Begin DoDot:1
- +23 if '$$DCIMO(PSGP,PSJDA,"P")
- QUIT
- +24 IF PSGALO'<1060
- IF $PIECE(PSJSYSW0,U,15)
- IF $PIECE($GET(^PS(53.1,PSJDA,0)),U,9)="N"
- KILL DA
- DO ENLBL^PSIVOPT(PSGTOL,PSGUOW,DFN,2,+PSJDA,"AD")
- +25 KILL DA
- SET DA=PSJDA
- Begin DoDot:2
- +26 KILL TMP
- +27 SET TMP(53.1,""_PSJDA_","_"",28)="D"
- +28 SET TMP(53.1,""_PSJDA_","_"",42)=1
- +29 DO FILE^DIE("","TMP")
- +30 KILL TMP
- End DoDot:2
- IF $PIECE($GET(^PS(53.1,DA,0)),"^",21)
- DO EN1^PSJHL2(PSGP,"OC",PSJDA_"P","AUTO DC")
- End DoDot:1
- +31 ;
- ENIV ;
- +1 SET DFN=PSGP
- FOR PSJIVON=0:0
- SET PSJIVON=$ORDER(^PS(55,DFN,"IV",PSJIVON))
- if 'PSJIVON
- QUIT
- SET Y=$GET(^(PSJIVON,0))
- IF "PDEN"'[$PIECE(Y,U,17)
- SET P(17)=$PIECE(Y,U,17)
- SET P(3)=$PIECE(Y,U,3)
- DO DC
- +2 QUIT
- DC ;
- +1 if '$$DCIMO(DFN,PSJIVON,"V")
- QUIT
- +2 SET (ON,ON55)=PSJIVON_"V"
- DO NOW^%DTC
- IF P(17)="H"
- IF P(3)<%
- Begin DoDot:1
- +3 KILL TMP
- +4 SET TMP(55.01,""_+ON_","_DFN_","_"",100)="E"
- +5 DO FILE^DIE("","TMP")
- +6 KILL TMP
- End DoDot:1
- DO EXPIR^PSIVOE
- QUIT
- +7 KILL PSIVALT
- SET PSIVAC="AD"
- SET PSIVALCK="STOP"
- SET PSIVREA="D"
- SET PSIVAL=$SELECT('+$GET(PSGALO):$GET(PSIVRES),1:$PIECE($GET(^PS(53.3,+PSGALO,0)),U))
- DO D1^PSIVOPT2
- DO LOG^PSIVORAL
- +8 KILL TMP
- +9 SET TMP(55.01,""_+ON_","_DFN_","_"",157)=$SELECT($GET(PSGALO)=1010:"DD",1:"DA")
- +10 SET TMP(55.01,""_+ON_","_DFN_","_"",.03)=PSJDCDT
- +11 SET TMP(55.01,""_+ON_","_DFN_","_"",121)=1
- +12 DO FILE^DIE("","TMP")
- +13 KILL TMP
- +14 DO EN1^PSJHL2(DFN,"OD",+ON_"V","AUTO DC")
- +15 SET PSJIVDCF=1
- +16 QUIT
- +17 ;
- SIVDIE ; Setup DIE,DA for IV
- +1 KILL DA,DIE,DR
- SET DA=+ON
- SET DA(1)=DFN
- SET DIE="^PS(55,"_DFN_",""IV"","
- +2 QUIT
- +3 ;
- AUDDD ; set up orders for discharge report and purging
- +1 SET DIS=+VAIP(17,1)
- IF $SELECT('DIS:1,1:$DATA(^PS(55,"AUDDD",DIS,PSGP)))
- QUIT
- +2 SET X=$$EN^PSGCT(+VAIP(13,1),-1)
- +3 FOR Q=X:0
- SET Q=$ORDER(^PS(55,PSGP,5,"AUS",Q))
- if 'Q
- QUIT
- FOR QQ=0:0
- SET QQ=$ORDER(^PS(55,PSGP,5,"AUS",Q,QQ))
- if 'QQ
- QUIT
- IF $SELECT($DATA(^PS(55,PSGP,5,QQ,0)):'$PIECE(^(0),"^",20),1:1)
- SET $PIECE(^(0),"^",20)=DIS
- SET ^PS(55,"AUDDD",DIS,PSGP,QQ)=""
- +4 QUIT
- +5 ;
- ENHE ; status from hold to expired
- +1 DO NOW^%DTC
- SET PSGDT=+$EXTRACT(%,1,12)
- SET DIE="^PS(55,"_PSGP_",5,"
- +2 FOR PSJS=+PSJPAD:0
- SET PSJS=$ORDER(^PS(55,PSGP,5,"AUS",PSJS))
- if 'PSJS
- QUIT
- if PSJS>PSGDT
- QUIT
- FOR PSJDA=0:0
- SET PSJDA=$ORDER(^PS(55,PSGP,5,"AUS",PSJS,PSJDA))
- if 'PSJDA
- QUIT
- KILL DA
- SET DA(1)=PSGP
- SET DA=PSJDA
- IF $DATA(^PS(55,PSGP,5,DA,0))
- IF $PIECE(^(0),"^",9)="H"
- SET DR="28////E"
- DO ^DIE
- +3 QUIT
- +4 ;
- ENUNDC(PSJDCDT,PSGP,PSJUOW,PSGALO) ; Auto-reinstate orders DC'ed due to a patient movement.
- +1 NEW PSJSYSW0
- DO NOW^%DTC
- SET PSJUNDC=1
- SET PSGDT=%
- SET PSJFIRST='$DATA(PSJQUIET)
- SET PSJSYSW0=$GET(^PS(59.6,+$ORDER(^PS(59.6,"B",+PSJUOW,0)),0))
- +2 SET PSJS=$ORDER(^PS(55,PSGP,5,"AUS",PSJDCDT-.0002))
- FOR PSGORD=0:0
- SET PSGORD=$ORDER(^PS(55,PSGP,5,"AUS",+PSJS,PSGORD))
- if 'PSGORD
- QUIT
- Begin DoDot:1
- +3 IF $PIECE($GET(^PS(55,PSGP,5,PSGORD,0)),U,9)["D"
- IF $PIECE($GET(^(4)),U,11)
- DO DISREIN
- DO ENRI^PSGOERI
- +4 SET ^PS(55,"AUE",PSGP,PSGORD)=""
- End DoDot:1
- +5 ;
- +6 if PSJS=""
- SET PSJS=$ORDER(^PS(55,PSGP,"IV","AIS",PSJDCDT-.0002))
- +7 FOR PSGORD=0:0
- SET PSGORD=$ORDER(^PS(55,PSGP,"IV","AIS",+PSJS,PSGORD))
- if 'PSGORD
- QUIT
- Begin DoDot:1
- +8 IF $PIECE($GET(^PS(55,PSGP,"IV",PSGORD,0)),U,12)
- IF $PIECE($GET(^(2)),U,7)>PSGDT
- SET P(3)=$PIECE($GET(^(0)),U,3)
- DO DISREIN
- DO ENARI^PSIVOPT(PSGP,PSGORD,+PSJUOW,PSGALO)
- End DoDot:1
- +9 IF $DATA(^TMP("PSJUNDC"))
- SET ^TMP("PSJUNDC",$JOB,DFN)=$PIECE(^DPT(DFN,0),"^")_"^"_$GET(^DPT(PSGP,.1))_"^"_PSGALO
- DO ^PSJADT2
- +10 ;
- ENKL ;
- +1 FOR UW=0:0
- SET UW=$ORDER(^PS(53.41,1,1,UW))
- if 'UW
- QUIT
- Begin DoDot:1
- +2 FOR PSGP=0:0
- SET PSGP=$ORDER(^PS(53.41,1,1,UW,1,PSGP))
- if 'PSGP
- QUIT
- Begin DoDot:2
- +3 FOR TO=0:0
- SET TO=$ORDER(^PS(53.41,1,1,UW,1,PSGP,1,TO))
- if 'TO
- QUIT
- Begin DoDot:3
- +4 IF '$ORDER(^PS(53.41,1,1,UW,1,PSGP,1,TO,1,0))
- KILL DA
- SET DA(3)=1
- SET DA(2)=UW
- SET DA(1)=PSGP
- SET DA=TO
- SET DIK="^PS(53.41,1,1,"_UW_",1,"_PSGP_",1,"
- DO ^DIK
- End DoDot:3
- IF '$ORDER(^PS(53.41,1,1,UW,1,PSGP,1,0))
- KILL DA
- SET DA(2)=1
- SET DA(1)=UW
- SET DA=PSGP
- SET DIK="^PS(53.41,1,1,"_UW_",1,"
- DO ^DIK
- End DoDot:2
- IF '$ORDER(^PS(53.41,1,1,UW,1,0))
- KILL DA
- SET DIK="^PS(53.41,1,1,"
- SET DA(1)=1
- SET DA=UW
- DO ^DIK
- End DoDot:1
- IF '$ORDER(^PS(53.41,1,1,0))
- KILL DA
- SET DA=1
- SET DIK="^PS(53.41,"
- DO ^DIK
- +5 KILL DA,DIK,P,PSGDT,PSGP,PSGORD,PSJS,PSJUNDC,TO,UW
- +6 QUIT
- +7 ;
- DISREIN ; Display reinstate msg. for first order.
- +1 if PSJFIRST&'$DATA(DGQUIET)
- WRITE !,"...reinstating Inpatient Medication orders..."
- SET PSJFIRST=0
- +2 QUIT
- +3 ;
- DCIMO(DFN,ON,TYP) ; Check parameter before DC'ing clinic order
- +1 NEW GLO,IMOND,A,CLINIC,APPT,B,C
- SET GLO=$SELECT(TYP="P":"^PS(53.1,",TYP="U":"^PS(55,"_DFN_",5,",TYP="V":"^PS(55,"_PSGP_",""IV"",",1:"")
- IF TYP=""
- QUIT 1
- +2 SET IMOND=$SELECT(TYP="P"!(TYP="V"):"""DSS""",TYP="U":8,1:"")
- IF IMOND=""
- QUIT 1
- +3 SET GLO=GLO_+ON_","_IMOND_")"
- SET A=$GET(@GLO)
- SET CLINIC=$PIECE(A,"^")
- SET APPT=$PIECE(A,"^",2)
- +4 if '$$CLINIC^PSJBCMA(A)
- QUIT 1
- +5 IF '$DATA(^PS(53.46,"B",CLINIC))
- QUIT 1
- +6 ;p390 .351 Patient DATE OF DEATH
- IF $$GET1^DIQ(2,DFN,.351,"I")
- QUIT 1
- +7 SET B=$ORDER(^PS(53.46,"B",CLINIC,""))
- SET C=+$PIECE(^PS(53.46,B,0),"^",3)
- QUIT C