- 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 Jan 18, 2025@03:03:55 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