- 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 Jan 18, 2025@03:09:48 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 ;