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