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

PSJPADE.m

Go to the documentation of this file.
  1. PSJPADE ;BIR/MHA PADE SYSTEM SET UP ;6/10/15
  1. ;;5.0;INPATIENT MEDICATIONS;**317,337,410,432**;16 DEC 97;Build 18
  1. ;Reference to ^DGPMDDCF supported by DBIA 1246
  1. ;Reference to ^DPT("CN" supported by DBIA 10035
  1. ;Reference to ^SC supported by DBIA 10040
  1. ;Reference to ^DIC(42 supported by DBIA 10039
  1. ;Reference to ^HLMA (#773) supported by DBIA 4738
  1. Q
  1. PADE ;enter/edit PADE system setup
  1. W ! N PSJDIV,DA,DR S (DIC,DIE)="^PS(58.7,",DLAYGO=58.7,DIC(0)="AEQL"
  1. I $D(^XUSEC("PSJ PADE ADV",DUZ)) S DIC(0)="AEQ" K DLAYGO
  1. D ^DIC G:"^"[$E(X) PDX G:Y<1 PADE S DA=+Y,DR="[PSJ PADE SYSTEM]" W ! D ^DIE G PADE
  1. PDX K DIE,DIC
  1. Q
  1. ;
  1. PDSAR ;enter/edit SEND AREA
  1. W ! S (DIC,DIE)=58.71,DLAYGO=58.71,DIC(0)="AEQL" D ^DIC G:"^"[$E(X) PDARX G:Y<1 PDARX S DA=+Y,DR=".01" D ^DIE G PDSAR
  1. PDARX K DIE,DIC
  1. Q
  1. ;
  1. PDUSR ;PADE division setup
  1. N PSJAP,I,J,K,X,Y S (PSJAP,I)=0
  1. F S I=$O(^PS(58.7,I)) Q:'I S J=$$PDACT^PSJPDCLA(I)
  1. I 'PSJAP W !!,"PADE not setup - Quitting..." H 2 Q
  1. S (I,J)=0 F S I=$O(PSJAP(I)) Q:'I S J=J+1
  1. I J>1 D Q:Y<0
  1. .W ! K DIC S DIC("A")="Select PADE: ",DIC=58.7,DIC(0)="AEMQ"
  1. .S DIC("S")="I '$P(^PS(58.7,+Y,0),U,4)&($P(^PS(58.7,+Y,0),U,4)<DT)"
  1. .D ^DIC I Y<0 K DIC Q
  1. .S K=+Y,I=0 F S I=$O(PSJAP(I)) Q:'I K:I'=K PSJAP(I)
  1. S Y=$O(PSJAP(0))
  1. W !!,"You are logged under PADE: "_$P($G(^PS(58.7,Y,0)),"^"),!
  1. N PSJDIV S DIE="^PS(58.7,",DA=+Y,DR="[PSJ PADE SYSTEM]"
  1. D ^DIE
  1. K DIE,DIC
  1. Q
  1. BDCHK(QZ) ;CHECK IF BED IS OUT-OF-SERVICE
  1. N J S J=X N D0,X S D0=QZ D RIN^DGPMDDCF
  1. I X W !,"BED is marked as OUT-OF-SERVICE",! Q 1
  1. ;CHECK IF BED IS ASSIGNED TO ANOTHER GROUP
  1. S X=J,J=0,J=$O(^PS(58.7,DA(3),"DIV",DA(2),"BG","C",X,J))
  1. Q:'J 0
  1. S J=$G(^PS(58.7,DA(3),"DIV",DA(2),"BG",J,0))
  1. S:J="" J="UNKNOWN"
  1. W !,"Bed is already assigned to group "_J,!
  1. Q 1
  1. ;
  1. CLCHK(QZ) ;CHECK IF CLINIC IS DEFINED IN ANOTHER GROUP
  1. I $P(^(0),U,3)'="C" Q 0
  1. I $P(^(0),U,15)'=$S($G(PSJDIV):PSJDIV,1:DA(2)) Q 0
  1. N J S J=$O(^PS(58.7,DA(3),"DIV",DA(2),"PCG","C",QZ,""))
  1. Q:'J 1
  1. S J=$G(^PS(58.7,DA(3),"DIV",DA(2),"PCG",J,0))
  1. S:J="" J="UNKNOWN"
  1. W !,$P(^SC(QZ,0),U)_" Clinic is already assigned to group "_J,!!
  1. Q 0
  1. ;
  1. WGSEL(Q) ;CHECK IF ATLEAST ONE WARD IN THIS GROUP BELONGS TO THE SAME DIVISION
  1. N I,J,K S (I,K)=0
  1. I $P(^(0),U,2)="P" D
  1. .F S I=$O(^PS(57.5,Q,1,I)) Q:'I!(K) D
  1. .. S J=+^PS(57.5,Q,1,I,0) Q:'J
  1. .. N D0,X S D0=J D WIN^DGPMDDCF Q:X
  1. .. S J=+$P($G(^DIC(42,J,0)),"^",11) Q:'J
  1. .. I J=$S($G(PSJDIV):PSJDIV,1:DA) S K=1
  1. Q K
  1. ;
  1. ORSEL() ;CHECK IF OR BELONGS TO THE SAME DIVISION
  1. N FF S FF=0
  1. I $P(^(0),U,15)=$S($G(PSJDIV):PSJDIV,1:DA(1))&($D(^SC("AC","OR",Y))) D
  1. .I '$P($G(^SC(Y,"I")),U)!(+$P($G(^SC(Y,"I")),U)'<DT) S FF=1
  1. Q FF
  1. ;
  1. PDORD ;
  1. N PSJAP,PSJCLPD,PSJPDNM,I,J,K,L,X,Y,Z S (PSJAP,I)=0
  1. F S I=$O(^PS(58.7,I)) Q:'I S J=$$PDACT^PSJPDCLA(I)
  1. I 'PSJAP W !!,"PADE not setup - Quitting..." H 2 Q
  1. SEL ;
  1. D ENCV^PSGSETU
  1. W !
  1. K DIR,DIRUT
  1. K PSJDIV,DIVI,DFN,RXO,PSJHLDFN,PDTYP,ALLC,SCL,SWD,WDN,PDCL,PDWD,NIV
  1. S DIR("?")="^D PDH^PSJPADE",DIR("A")="Select By",DIR("B")=$S($D(SEL):SEL,1:"PT")
  1. S DIR(0)="SMB^PT:PATIENT;WD:WARD;CL:CLINIC;E:EXIT"
  1. D ^DIR K DIR I $D(DIRUT)!(Y="E") K SEL,X,Y Q
  1. S SEL=Y
  1. G:SEL="PT" PT
  1. D:'$G(PSJCLPD) SELPD
  1. G:'$G(PSJCLPD) SEL
  1. W !!,"You are logged under PADE: "_PSJPDNM,!
  1. DIV ;
  1. W ! K DIC S DIC=40.8,DIC(0)="AEMQ",DIC("A")="Select DIVISION: " D ^DIC K DIC
  1. G:Y<0 SEL
  1. S PSJDIV=+Y
  1. S DIVI=$G(^PS(58.7,PSJCLPD,"DIV",PSJDIV,0))
  1. I DIVI=""!($P(DIVI,"^",2)&($P(DIVI,"^",2)<DT)) W !,"This division is not setup for this PADE.",! G DIV
  1. I $P($G(^(2)),"^")'="Y" W !,"This division is not setup to send order messages.",! G DIV
  1. W !!,"You are logged under Division: "_$P(Y,"^",2),!!
  1. S NIV=$P(DIVI,"^",7)'="Y"
  1. G:SEL="CL" CL
  1. WD ;
  1. I '$O(PDWD(0)) D WDARR
  1. R !,"Select a Ward or ^ALL for all Wards: ",X:DTIME
  1. G:"^"[X SEL
  1. I "^AL"'[$E(X,1,3) G SWD
  1. I '$D(^XUSEC("PSJ PADE MGR",DUZ)) W !!,"You must have the PSJ PADE MGR key to send all orders",! G WD
  1. N CNT,WDCNT,Z11 S Z11=0
  1. F S Z11=$O(PDWD(Z11)) Q:'Z11 D
  1. . S WDN=$P(^DIC(42,Z11,0),"^")
  1. . I '$D(^DPT("CN",WDN)) W !,"No patient in WARD "_WDN
  1. . E W !,"Sending ward "_WDN S WDCNT=0 D SDWD W:'$G(WDCNT) !,?2,"No patients with active orders for this ward"
  1. G SEL
  1. ;
  1. SWD ;
  1. W ! K SWD,WDN K DIC S DIC="^DIC(42,",DIC(0)="QME"
  1. S DIC("S")="I $P(^(0),U,11)=PSJDIV"
  1. D ^DIC K DIC G:"^"[X SEL G:Y<0 WD
  1. S SWD=+Y,WDN=$P(Y,"^",2)
  1. I '$D(^DPT("CN",WDN)) W !!,"This ward has no patient",! G WD
  1. I '$D(PDWD(SWD)) W !!,"Ward is not setup for this PADE.",! G WD
  1. D SDWD
  1. K SWD,WDN
  1. G WD
  1. ;
  1. PDH ;
  1. W !!,"Enter 'PT' to send orders by Patient"
  1. W !," 'WD' to send orders by Ward"
  1. W !," 'CL' to send orders by Clinic"
  1. W !," or 'E' or '^' to exit" W !
  1. Q
  1. ;
  1. SELPD ;
  1. S (I,J)=0 F S I=$O(PSJAP(I)) Q:'I S J=J+1
  1. I J>1 D Q:$D(DTOUT)!($D(DUOUT)) I X="" W !,"You must select a PADE" G SELPD
  1. .W ! S DIC("A")="Select PADE: ",DIC=58.7,DIC(0)="AEMQ"
  1. .S DIC("S")="I '$P(^PS(58.7,+Y,0),U,4)&($P(^PS(58.7,+Y,0),U,4)<DT)"
  1. .D ^DIC K DIC Q:Y<0
  1. .S PSJCLPD=+Y,I=0 F S I=$O(PSJAP(I)) Q:'I K:I'=PSJCLPD PSJAP(I)
  1. S PSJCLPD=$O(PSJAP(0)),PSJPDNM=$P($G(^PS(58.7,PSJCLPD,0)),"^")
  1. Q
  1. PT ;
  1. K DFN
  1. D ENDPT^PSJP
  1. G:'$G(DFN) SEL
  1. D GETPTO(DFN,0)
  1. K DFN G PT
  1. ;
  1. GETPTO(RESNDDFN,RESNDCLN) ;
  1. ; RESNDDFN=Specific Patient to be sent/re-sent (optional)
  1. ; RESNDCLN=Specific Clinic to be sent/re-sent (optional)
  1. K ^TMP("PS",$J) S CNT=0 N PTN
  1. I $G(RESNDDFN) S DFN=RESNDDFN
  1. D OCL1^PSJORRE(DFN,"","",0)
  1. S PTN=$P($G(^DPT(DFN,0)),"^")_" ("_$E($P($G(^DPT(DFN,0)),"^",9),6,9)_")"
  1. I '$D(^TMP("PS",$J)) D Q
  1. .I '$G(RESNDCLN) W:SEL="PT" !,"No Orders found for "_PTN,!
  1. S I=0 S I=$O(^TMP("PS",$J,I)) I 'I D Q
  1. .I '$G(RESNDCLN) W:SEL="PT" !,"No Orders found for "_PTN,!
  1. N PDO,FP S I=0
  1. F S I=$O(^TMP("PS",$J,I)) Q:'I D
  1. .S J=^TMP("PS",$J,I,0),FP=$P(J,"^")
  1. .I (FP["U"!(FP["V")&($P(J,"^",9)="ACTIVE")) S PDO($P(FP,";"))="",CNT=CNT+1,WDCNT=1
  1. I '$O(PDO("")) D Q
  1. .I '$G(RESNDCLN) W:SEL="PT" !,"No active IV/UD Orders found for "_PTN,!
  1. I '$G(RESNDCLN) W !,?2,CNT_" Order(s) Queued for "_PTN,!
  1. S PDTYP="SN",PSJHLDFN=DFN
  1. S RXO=0 F S RXO=$O(PDO(RXO)) Q:'RXO D
  1. .D PDORD^PSJPDCLU(RESNDCLN)
  1. Q
  1. ;
  1. CL ;
  1. N ALL44 S ALL44=$P(DIVI,"^",3)="Y"
  1. I '$O(PDCL(0)) I 'ALL44 D CLARR
  1. K ALLC
  1. R !,"Select a Clinic or ^ALL for all Clinics: ",X:DTIME
  1. G:"^"[X SEL
  1. I "^AL"'[$E(X,1,3) G SCL
  1. I '$D(^XUSEC("PSJ PADE MGR",DUZ)) W !!,"You must have the PSJ PADE MGR key to send all orders",! G CL
  1. S ALLC=1 D SDCL
  1. G SEL
  1. ;
  1. SCL ;
  1. W ! K SCL K DIC S DIC="^SC(",DIC(0)="QME"
  1. S DIC("S")="I $P(^(0),U,3)=""C"",$P(^(0),U,15)=PSJDIV"
  1. D ^DIC K DIC G:"^"[X SEL G:Y<0 CL
  1. S SCL=+Y
  1. I '$D(PDCL(SCL)),'ALL44 W !!,"Clinic is not setup for this PADE.",! G CL
  1. D SDCL
  1. K SCL
  1. G CL
  1. ;
  1. SDCL ;
  1. W !,"Orders Queued to be sent to PADE",!
  1. N BDT S BDT=DT_".000001"
  1. F S BDT=$O(^PS(55,"AUD",BDT)) Q:'BDT D
  1. .S DFN=0 F S DFN=$O(^PS(55,"AUD",BDT,DFN)) Q:'DFN D
  1. .. S I=0 F S I=$O(^PS(55,"AUD",BDT,DFN,I)) Q:'I D
  1. ... S J=$G(^PS(55,DFN,5,I,0)) Q:$P(J,"^",9)'="A"
  1. ... S K=$G(^(8)) Q:'$P(K,"^",2) S K=+K Q:'K
  1. ... I $G(SCL),K=$G(SCL) D SDO Q
  1. ... I $G(ALLC),$D(PDCL),$D(PDCL(K)) D SDO Q
  1. ... I $G(ALLC),ALL44,$P(^SC(K,0),U,15)=PSJDIV D SDO Q
  1. Q:NIV
  1. SDCIV ;
  1. S L="V",BDT=DT_".000001"
  1. F S BDT=$O(^PS(55,"AIV",BDT)) Q:'BDT D
  1. .S DFN=0 F S DFN=$O(^PS(55,"AIV",BDT,DFN)) Q:'DFN D
  1. .. S I=0 F S I=$O(^PS(55,"AIV",BDT,DFN,I)) Q:'I D
  1. ... S J=$G(^PS(55,DFN,"IV",I,0)) Q:$P(J,"^",17)'="A"
  1. ... S K=+$G(^("DSS")) Q:'K
  1. ... I $G(SCL),K=$G(SCL) D SDO Q
  1. ... I $G(ALLC),$D(PDCL),$D(PDCL(K)) D SDO Q
  1. ... I $G(ALLC),ALL44,$P(^SC(K,0),U,15)=PSJDIV D SDO Q
  1. Q
  1. ;
  1. SDO ;
  1. S RXO=I_$S($G(L)="V":L,1:"U"),PDTYP="SN",PSJHLDFN=DFN
  1. D PDORD^PSJPDCLU(0)
  1. Q
  1. ;
  1. CLARR ;
  1. N Z S I=0
  1. F S I=$O(^PS(58.7,PSJCLPD,"DIV",PSJDIV,"CL",I)) Q:'I S PDCL(+^(I,0))=""
  1. S I=0
  1. F S I=$O(^PS(58.7,PSJCLPD,"DIV",PSJDIV,"PCG",I)) Q:'I D
  1. . S J=0 F S J=$O(^PS(58.7,PSJCLPD,"DIV",PSJDIV,"PCG",I,1,J)) Q:'J D
  1. .. S K=^(J,0) I '$D(PDCL(K)) S PDCL(K)=""
  1. S I=0
  1. F S I=$O(^PS(58.7,PSJCLPD,"DIV",PSJDIV,"VCG",I)) Q:'I S J=^(I,0) D
  1. . S Z=0 F S Z=$O(^PS(57.8,+J,1,Z)) Q:'Z D
  1. .. S K=^(Z,0) I '$D(PDCL(K)) S PDCL(K)=""
  1. S I=0,L=""
  1. F S I=$O(^PS(58.7,PSJCLPD,"DIV",PSJDIV,"WCN",I)) Q:'I S J=^(I,0) D
  1. . S Y=$P(J,"^"),Z=$E(Y,1,$L(Y)-1) F S Z=$O(^SC("B",Z)) Q:Z="" D
  1. .. Q:($E(Z,1,$L(Y))'=Y) ;p410
  1. .. S K=$O(^SC("B",Z,0)),L=$G(^SC(K,0)) Q:$P(L,"^",3)'="C" Q:$P(L,"^",15)'=PSJDIV D
  1. ... I '$D(PDCL(K)) S PDCL(K)=""
  1. Q
  1. ;
  1. WDARR ;
  1. S I=0
  1. F S I=$O(^PS(58.7,PSJCLPD,"DIV",PSJDIV,"WD","B",I)) Q:'I S PDWD(I)=""
  1. S I=0
  1. F S I=$O(^PS(58.7,PSJCLPD,"DIV",PSJDIV,"WG","B",I)) Q:'I D
  1. . S J=0 F S J=$O(^PS(57.5,I,1,J)) Q:'J S K=(+^(J,0)) S:'$D(PDWD(K)) PDWD(K)=""
  1. Q
  1. ;
  1. SDWD ;
  1. S DFN=0 F S DFN=$O(^DPT("CN",WDN,DFN)) Q:'DFN D
  1. .D GETPTO(DFN,0)
  1. Q
  1. ;
  1. LOG ;
  1. Q:'$O(PDL(0))
  1. N HLI
  1. I PSJSND>0 S PDL(3)=+PSJSND D
  1. .S HLI=$$FIND1^DIC(773,,"X",+PSJSND,"C")
  1. .S HLI=$$GET1^DIQ(773,HLI,.01,"I") S:HLI PDL(17)=HLI
  1. S:+PSJSND<1 PDL(13)=$P(PSJSND,"^",3)
  1. S DR="",LI=0
  1. F S LI=$O(PDL(LI)) Q:'LI S DR=DR_LI_"////"_PDL(LI)_";"
  1. K DD,DO,DIC
  1. D NOW^%DTC S DIC="^PS(58.72,",X=%,DIC(0)="",DIC("DR")=DR
  1. D FILE^DICN K DD,DO,Y,DIC,PDL
  1. Q
  1. ;
  1. RXC ;
  1. N PSJDD,PSJDU,RXC,DOS,NDF
  1. S I=0 F S I=$O(PS55(1,I)) Q:'I D
  1. .S PSJDD=$P(PS55(1,I,0),"^"),PSJDU=$P(PS55(1,I,0),"^",2)
  1. .I $P(PS55(1,I,0),"^",3),$P(PS55(1,I,0),"^",3)'>DT Q
  1. .S SEG="RXC"_NFS_"A"
  1. .S $P(SEG,NFS,3)=PSJDD_NECH_$P($G(^PSDRUG(PSJDD,0)),"^")_NECH_"99PSD"
  1. .S DOS=$G(^PSDRUG(PSJDD,"DOS")),NDF=$G(^("ND"))
  1. .D:$P(DOS,"^")
  1. .. Q:$P($G(^PS(50.607,$P(DOS,"^",2),0)),"^")["/"!($P($G(^PS(50.607,$P(DOS,"^",2),0)),"^")["%")
  1. .. S $P(SEG,NFS,4)=$P(DOS,"^")*PSJDU_NFS_NECH_$P($G(^PS(50.607,$P(DOS,"^",2),0)),"^")
  1. .. S $P(SEG,NFS,6)=$P(DOS,"^")_NFS_NECH_$P($G(^PS(50.607,$P(DOS,"^",2),0)),"^")
  1. .I $P(DOS,"^")="",$P(NDF,"^",3) D
  1. .. S DOS=$P($$DFSU^PSNAPIS("",$P(NDF,"^",3)),"^",4,6)
  1. .. D:DOS
  1. ... Q:$P(DOS,"^",3)["/"!($P(DOS,"^",3)["%")
  1. ... S $P(SEG,NFS,4)=+DOS*PSJDU_NFS_NECH_$P(DOS,"^",3)
  1. ... S $P(SEG,NFS,6)=$P(DOS,"^")_NFS_NECH_$P(DOS,"^",3)
  1. .S SEQ=SEQ+1
  1. .S NSEG(SEQ)=SEG
  1. .D:$D(^XTMP("PADE")) DISP^PSJPDCLU
  1. Q
  1. ;