PSGPER1 ;BIR/CML3-PRINTS PRE-EXCHANGE NEEDS REPORT ; 2/8/18 11:56am
;;5.0;INPATIENT MEDICATIONS;**80,127,279,359**;16 DEC 97;Build 7
;
EN ; Entry point
S PSGPERRF=0,POP=0 N PSGPRCLD,PSGCURCL S PSGPRCLD="" D DEFCL(PSGPXN,.PSGPRCLD)
N PSGPRTYP,PSGPRCL
I $G(PSGPRCLD("WARD")) S PSGPRTYP="PSGPERP" D DEV K PSGPRCLD("WARD")
I POP D POP G:%=1 EN G DONE
I $D(PSGPRCLD)>1 S PSGPRTYP="PSGPERPC" S PSGCURCL="" F S PSGCURCL=$O(PSGPRCLD("DEV",PSGCURCL)) Q:PSGCURCL="" D DEV
D DONE
Q
DEV ; Select Device
S PSGION=ION
D DEV1
Q
DEV0 ; Validate Device
S PSGION=ION
DEV1 ; Device validation loop
W !!,"PRE-EXCHANGE UNITS REPORT"
K IOP,%ZIS,IO("Q") S %ZIS="Q",%ZIS("A")="Select DEVICE for "_$S($G(PSGPRCLD("WARD")):"Ward "_$G(^DPT(DFN,.1)),$G(PSGCURCL)]"":"Clinic "_PSGCURCL,1:"")_": ",%ZIS("B")=$S(($G(PSGCURCL)]""):$G(PSGPRCLD("DEV",PSGCURCL)),1:"")
D ^%ZIS K %ZIS
I POP D POP G:%=1 DEV1
I $D(IO("Q")) K ZTSAVE S PSGTIR="^PSGPER2",ZTDESC="PRE-EXCHANGE UNITS REPORT",ZTDTH=$H,ZTSAVE("PSGPXN")="",ZTSAVE("DFN")="",ZTSAVE("PSGPRTYP")="",ZTSAVE("PSGCURCL")="" D ENTSK^PSGTI G:'$D(ZTSK) DEV0 K ZTSK
D ENP^PSGPER2,AG I %=1 S PSGPERRF=1 G DEV0
Q
;
DONE ;
OUT ;
D TASKPRGE^PSGPER1(PSGPXN) ;
K PSGPERRF,PSGPXN
Q:$G(PSJCOM)!$G(PSJPREX)
D ENIVKV^PSGSETU,ENCV^PSGSETU
Q
;
POP ;
S %=2 W:'PSGPERRF !!,"IF A DEVICE IS NOT CHOSEN, NO REPORT WILL BE RUN AND THE DATA WILL NO LONGER BE RETRIEVABLE THROUGH THIS REPORT."
I 'PSGPERRF F W !,"Do you want another chance to choose a device" S %=1 D YN^DICN Q:% W !?3,"Enter 'YES' to choose a device to print. Enter 'NO' to quit now."
I %'=1 S IOP=PSGION D ^%ZIS S %=2
Q
;
AG ;
F W !!,"DO YOU NEED TO PRINT THIS REPORT AGAIN" S %=0 D YN^DICN Q:% D AGMSG
Q
;
AGMSG ;
I %Y'?1."?" W $C(7)," ANSWER 'YES' OR 'NO' (Entry required)" Q
W !," Enter 'YES' to print this report again. Enter 'NO' (or an '^') to quit",!,"now. PLEASE NOTE that you will NOT be able to retrieve this data at a later",!,"date. You should print this information now." Q
;
DEFON() ; All Pre-Exchange Devices have been removed from Ward Parameters - restore previous functionality
N ON,W S ON=0,W=0 F S W=$O(^PS(59.6,W)) Q:'W!ON I $P(^(W,0),U,29)]"" S ON=1
I $G(PSJPXDOF) S ON=0 K PSJPXDOF
Q ON
;
DEFCL(PSGPXN,CLINICS) ; Default devices for Clinics
K CLINICS N CLINIC,CLINM,CLINX,CLINDEV
N CLINAM,DFN S DFN=0 F S DFN=$O(^PS(53.4,PSGPXN,1,DFN)) Q:'DFN S ON=0 F S ON=$O(^PS(53.4,PSGPXN,1,DFN,1,ON)) Q:'ON D
.S CLINIC=$$CLINIC^PSJO1(DFN,+ON_"U")
.I CLINIC]"" N CLINUM,DIC,X,Y S DIC="^SC(",DIC(0)="NSUXZ",X=CLINIC D ^DIC I $G(Y)>0 S CLINUM=+Y D
..S CLINAM=CLINIC N LCLCL S LCLCL=$P($G(PSJSYSW0("CLINIC",+CLINUM,1)),"^")
..I $G(PSJSYSW0("CLINIC",+CLINUM,0)) S CLINICS("DEV",CLINAM)=$$GET1^DIQ(3.5,+LCLCL,".01"),CLINICS("DEVX",+CLINIC)=CLINAM
.I CLINIC="" S CLINICS("WARD")=1
Q
TASKPRGE(PXN) ; Task purge of entry from file 53.4
Q:$D(^XTMP("PSGPER1:"_$G(PXN),0)) ;p359
K ZTIO,ZTDTH,ZTSK S ZTIO="",ZTRTN="PURGE^PSGPER1",ZTDESC="PURGE PRE-EXCHANGE NEEDS" S ZTSAVE("PXN")="" S ZTDTH=$$HADD^XLFDT($H,1,0,0,0)
D ^%ZTLOAD
S:$G(PXN) ^XTMP("PSGPER1:"_PXN,0)=$$FMADD^XLFDT($$DT^XLFDT,7,0,0,0)_"^"_$$DT^XLFDT_"^File 53.4 purge log" ;p359
K %ZIS,IOP,PSGTID,PSGTIR,ZTDESC,ZTDTH,ZTRTN,ZTDESC,ZTSAVE
Q
PURGE ; Purge entry from file 53.4
Q:'$G(PXN)
K ^XTMP("PSGPER1:"_PXN) ;p359
N PSGPXINF,PSGNOWFM S PSGPXINF=$G(^PS(53.4,+$G(PXN),0)),PSGPXINF=$P($P(PSGPXINF,"^",2),".") Q:'$G(PSGPXINF)
S PSGNOWFM=$P($$NOW^XLFDT,".") Q:'(PSGNOWFM>PSGPXINF)
S DIK="^PS(53.4,",DA=PXN D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPER1 3587 printed Dec 13, 2024@02:02:41 Page 2
PSGPER1 ;BIR/CML3-PRINTS PRE-EXCHANGE NEEDS REPORT ; 2/8/18 11:56am
+1 ;;5.0;INPATIENT MEDICATIONS;**80,127,279,359**;16 DEC 97;Build 7
+2 ;
EN ; Entry point
+1 SET PSGPERRF=0
SET POP=0
NEW PSGPRCLD,PSGCURCL
SET PSGPRCLD=""
DO DEFCL(PSGPXN,.PSGPRCLD)
+2 NEW PSGPRTYP,PSGPRCL
+3 IF $GET(PSGPRCLD("WARD"))
SET PSGPRTYP="PSGPERP"
DO DEV
KILL PSGPRCLD("WARD")
+4 IF POP
DO POP
if %=1
GOTO EN
GOTO DONE
+5 IF $DATA(PSGPRCLD)>1
SET PSGPRTYP="PSGPERPC"
SET PSGCURCL=""
FOR
SET PSGCURCL=$ORDER(PSGPRCLD("DEV",PSGCURCL))
if PSGCURCL=""
QUIT
DO DEV
+6 DO DONE
+7 QUIT
DEV ; Select Device
+1 SET PSGION=ION
+2 DO DEV1
+3 QUIT
DEV0 ; Validate Device
+1 SET PSGION=ION
DEV1 ; Device validation loop
+1 WRITE !!,"PRE-EXCHANGE UNITS REPORT"
+2 KILL IOP,%ZIS,IO("Q")
SET %ZIS="Q"
SET %ZIS("A")="Select DEVICE for "_$SELECT($GET(PSGPRCLD("WARD")):"Ward "_$GET(^DPT(DFN,.1)),$GET(PSGCURCL)]"":"Clinic "_PSGCURCL,1:"")_": "
SET %ZIS("B")=$SELECT(($GET(PSGCURCL)]""):$GET(PSGPRCLD("DEV",PSGCURCL)),1:"")
+3 DO ^%ZIS
KILL %ZIS
+4 IF POP
DO POP
if %=1
GOTO DEV1
+5 IF $DATA(IO("Q"))
KILL ZTSAVE
SET PSGTIR="^PSGPER2"
SET ZTDESC="PRE-EXCHANGE UNITS REPORT"
SET ZTDTH=$HOROLOG
SET ZTSAVE("PSGPXN")=""
SET ZTSAVE("DFN")=""
SET ZTSAVE("PSGPRTYP")=""
SET ZTSAVE("PSGCURCL")=""
DO ENTSK^PSGTI
if '$DATA(ZTSK)
GOTO DEV0
KILL ZTSK
+6 DO ENP^PSGPER2
DO AG
IF %=1
SET PSGPERRF=1
GOTO DEV0
+7 QUIT
+8 ;
DONE ;
OUT ;
+1 ;
DO TASKPRGE^PSGPER1(PSGPXN)
+2 KILL PSGPERRF,PSGPXN
+3 if $GET(PSJCOM)!$GET(PSJPREX)
QUIT
+4 DO ENIVKV^PSGSETU
DO ENCV^PSGSETU
+5 QUIT
+6 ;
POP ;
+1 SET %=2
if 'PSGPERRF
WRITE !!,"IF A DEVICE IS NOT CHOSEN, NO REPORT WILL BE RUN AND THE DATA WILL NO LONGER BE RETRIEVABLE THROUGH THIS REPORT."
+2 IF 'PSGPERRF
FOR
WRITE !,"Do you want another chance to choose a device"
SET %=1
DO YN^DICN
if %
QUIT
WRITE !?3,"Enter 'YES' to choose a device to print. Enter 'NO' to quit now."
+3 IF %'=1
SET IOP=PSGION
DO ^%ZIS
SET %=2
+4 QUIT
+5 ;
AG ;
+1 FOR
WRITE !!,"DO YOU NEED TO PRINT THIS REPORT AGAIN"
SET %=0
DO YN^DICN
if %
QUIT
DO AGMSG
+2 QUIT
+3 ;
AGMSG ;
+1 IF %Y'?1."?"
WRITE $CHAR(7)," ANSWER 'YES' OR 'NO' (Entry required)"
QUIT
+2 WRITE !," Enter 'YES' to print this report again. Enter 'NO' (or an '^') to quit",!,"now. PLEASE NOTE that you will NOT be able to retrieve this data at a later",!,"date. You should print this information now."
QUIT
+3 ;
DEFON() ; All Pre-Exchange Devices have been removed from Ward Parameters - restore previous functionality
+1 NEW ON,W
SET ON=0
SET W=0
FOR
SET W=$ORDER(^PS(59.6,W))
if 'W!ON
QUIT
IF $PIECE(^(W,0),U,29)]""
SET ON=1
+2 IF $GET(PSJPXDOF)
SET ON=0
KILL PSJPXDOF
+3 QUIT ON
+4 ;
DEFCL(PSGPXN,CLINICS) ; Default devices for Clinics
+1 KILL CLINICS
NEW CLINIC,CLINM,CLINX,CLINDEV
+2 NEW CLINAM,DFN
SET DFN=0
FOR
SET DFN=$ORDER(^PS(53.4,PSGPXN,1,DFN))
if 'DFN
QUIT
SET ON=0
FOR
SET ON=$ORDER(^PS(53.4,PSGPXN,1,DFN,1,ON))
if 'ON
QUIT
Begin DoDot:1
+3 SET CLINIC=$$CLINIC^PSJO1(DFN,+ON_"U")
+4 IF CLINIC]""
NEW CLINUM,DIC,X,Y
SET DIC="^SC("
SET DIC(0)="NSUXZ"
SET X=CLINIC
DO ^DIC
IF $GET(Y)>0
SET CLINUM=+Y
Begin DoDot:2
+5 SET CLINAM=CLINIC
NEW LCLCL
SET LCLCL=$PIECE($GET(PSJSYSW0("CLINIC",+CLINUM,1)),"^")
+6 IF $GET(PSJSYSW0("CLINIC",+CLINUM,0))
SET CLINICS("DEV",CLINAM)=$$GET1^DIQ(3.5,+LCLCL,".01")
SET CLINICS("DEVX",+CLINIC)=CLINAM
End DoDot:2
+7 IF CLINIC=""
SET CLINICS("WARD")=1
End DoDot:1
+8 QUIT
TASKPRGE(PXN) ; Task purge of entry from file 53.4
+1 ;p359
if $DATA(^XTMP("PSGPER1
QUIT
+2 KILL ZTIO,ZTDTH,ZTSK
SET ZTIO=""
SET ZTRTN="PURGE^PSGPER1"
SET ZTDESC="PURGE PRE-EXCHANGE NEEDS"
SET ZTSAVE("PXN")=""
SET ZTDTH=$$HADD^XLFDT($HOROLOG,1,0,0,0)
+3 DO ^%ZTLOAD
+4 ;p359
if $GET(PXN)
SET ^XTMP("PSGPER1:"_PXN,0)=$$FMADD^XLFDT($$DT^XLFDT,7,0,0,0)_"^"_$$DT^XLFDT_"^File 53.4 purge log"
+5 KILL %ZIS,IOP,PSGTID,PSGTIR,ZTDESC,ZTDTH,ZTRTN,ZTDESC,ZTSAVE
+6 QUIT
PURGE ; Purge entry from file 53.4
+1 if '$GET(PXN)
QUIT
+2 ;p359
KILL ^XTMP("PSGPER1:"_PXN)
+3 NEW PSGPXINF,PSGNOWFM
SET PSGPXINF=$GET(^PS(53.4,+$GET(PXN),0))
SET PSGPXINF=$PIECE($PIECE(PSGPXINF,"^",2),".")
if '$GET(PSGPXINF)
QUIT
+4 SET PSGNOWFM=$PIECE($$NOW^XLFDT,".")
if '(PSGNOWFM>PSGPXINF)
QUIT
+5 SET DIK="^PS(53.4,"
SET DA=PXN
DO ^DIK
+6 QUIT
