Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSGPER1

PSGPER1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. EN ; Entry point
  1. S PSGPERRF=0,POP=0 N PSGPRCLD,PSGCURCL S PSGPRCLD="" D DEFCL(PSGPXN,.PSGPRCLD)
  1. N PSGPRTYP,PSGPRCL
  1. I $G(PSGPRCLD("WARD")) S PSGPRTYP="PSGPERP" D DEV K PSGPRCLD("WARD")
  1. I POP D POP G:%=1 EN G DONE
  1. I $D(PSGPRCLD)>1 S PSGPRTYP="PSGPERPC" S PSGCURCL="" F S PSGCURCL=$O(PSGPRCLD("DEV",PSGCURCL)) Q:PSGCURCL="" D DEV
  1. D DONE
  1. Q
  1. DEV ; Select Device
  1. S PSGION=ION
  1. D DEV1
  1. Q
  1. DEV0 ; Validate Device
  1. S PSGION=ION
  1. DEV1 ; Device validation loop
  1. W !!,"PRE-EXCHANGE UNITS REPORT"
  1. 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:"")
  1. D ^%ZIS K %ZIS
  1. I POP D POP G:%=1 DEV1
  1. 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
  1. D ENP^PSGPER2,AG I %=1 S PSGPERRF=1 G DEV0
  1. Q
  1. ;
  1. DONE ;
  1. OUT ;
  1. D TASKPRGE^PSGPER1(PSGPXN) ;
  1. K PSGPERRF,PSGPXN
  1. Q:$G(PSJCOM)!$G(PSJPREX)
  1. D ENIVKV^PSGSETU,ENCV^PSGSETU
  1. Q
  1. ;
  1. POP ;
  1. 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."
  1. 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."
  1. I %'=1 S IOP=PSGION D ^%ZIS S %=2
  1. Q
  1. ;
  1. AG ;
  1. F W !!,"DO YOU NEED TO PRINT THIS REPORT AGAIN" S %=0 D YN^DICN Q:% D AGMSG
  1. Q
  1. ;
  1. AGMSG ;
  1. I %Y'?1."?" W $C(7)," ANSWER 'YES' OR 'NO' (Entry required)" Q
  1. 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
  1. ;
  1. DEFON() ; All Pre-Exchange Devices have been removed from Ward Parameters - restore previous functionality
  1. 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
  1. I $G(PSJPXDOF) S ON=0 K PSJPXDOF
  1. Q ON
  1. ;
  1. DEFCL(PSGPXN,CLINICS) ; Default devices for Clinics
  1. K CLINICS N CLINIC,CLINM,CLINX,CLINDEV
  1. 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
  1. .S CLINIC=$$CLINIC^PSJO1(DFN,+ON_"U")
  1. .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
  1. ..S CLINAM=CLINIC N LCLCL S LCLCL=$P($G(PSJSYSW0("CLINIC",+CLINUM,1)),"^")
  1. ..I $G(PSJSYSW0("CLINIC",+CLINUM,0)) S CLINICS("DEV",CLINAM)=$$GET1^DIQ(3.5,+LCLCL,".01"),CLINICS("DEVX",+CLINIC)=CLINAM
  1. .I CLINIC="" S CLINICS("WARD")=1
  1. Q
  1. TASKPRGE(PXN) ; Task purge of entry from file 53.4
  1. Q:$D(^XTMP("PSGPER1:"_$G(PXN),0)) ;p359
  1. 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)
  1. D ^%ZTLOAD
  1. S:$G(PXN) ^XTMP("PSGPER1:"_PXN,0)=$$FMADD^XLFDT($$DT^XLFDT,7,0,0,0)_"^"_$$DT^XLFDT_"^File 53.4 purge log" ;p359
  1. K %ZIS,IOP,PSGTID,PSGTIR,ZTDESC,ZTDTH,ZTRTN,ZTDESC,ZTSAVE
  1. Q
  1. PURGE ; Purge entry from file 53.4
  1. Q:'$G(PXN)
  1. K ^XTMP("PSGPER1:"_PXN) ;p359
  1. N PSGPXINF,PSGNOWFM S PSGPXINF=$G(^PS(53.4,+$G(PXN),0)),PSGPXINF=$P($P(PSGPXINF,"^",2),".") Q:'$G(PSGPXINF)
  1. S PSGNOWFM=$P($$NOW^XLFDT,".") Q:'(PSGNOWFM>PSGPXINF)
  1. S DIK="^PS(53.4,",DA=PXN D ^DIK
  1. Q