PSJPDAPP ;BIR/MHA - SEND APPOINTMENTS TO PADE ;11/27/15
;;5.0;INPATIENT MEDICATIONS;**317,389,415**;16 DEC 97;Build 3
;Reference to ^PS(55 is supported by DBIA 2191
;Reference to ^ORD(101 supported by DBIA 872
;Reference to GETPLIST^SDAMA202 supported by DBIA 3869
;Reference to ^SC supported by DBIA 10040
;Reference to ^DPT supported by DBIA 10035
Q
;
EN ;
N PDA,PDCL,PDCLA,PDI,PDJ,PDK,PSJAP,PSJCLPD,PSJPDNM,PSJDIV,DTP,SA,SEQ,I,J,K,L,P,X,Y,Z,PSJNIP,X1,X2
S (DTP,PSJAP,I)=0
F S I=$O(^PS(58.7,I)) Q:'I S J=$$PDACT^PSJPDCLA(I)
Q:'PSJAP
S I=0 F S I=$O(PSJAP(I)) Q:'I D
. S DTP=+$G(^PS(58.7,I,1))
. S J=0 F S J=$O(^PS(58.7,I,"DIV",J)) Q:'J D
.. S Y=$G(^PS(58.7,I,"DIV",J,0)) I Y=""!($P(Y,"^",2)&($P(Y,"^",2)<DT)) Q
.. S SA=""
.. I $P(Y,"^",9)="Y" S:$P(Y,"^",4) SA=$P($G(^PS(58.71,$P(Y,"^",4),0)),"^") D ALLCLN ;send appt for all clinics
.. D CLARR
M PDCL=PDCLA
Q:'$D(PDCL)
N SNM,CNM S SNM="PSJ SIU-S12 SERVER",CNM="PSJ SIU-S12 CLIENT"
I '$O(^ORD(101,"B",SNM,0))!('$O(^ORD(101,"B",CNM,0))) Q
N NHL D INIT^HLFNC2(SNM,.NHL) Q:$D(NHL)=1
N NFS,NECH,HL,HLFS,NSEG,EDT,APT,DFN,PSJDTM,PSJND,PSJVP,PSJVNM,PSJDNS,PSJDNM,PSJOR,PSJORN
M HL=NHL S (NFS,HLFS)=HL("FS"),NECH=$E(HL("ECH"),1)
S PDI=0 F S PDI=$O(PDCL(PDI)) Q:'PDI D
. S PSJND=$G(^PS(58.7,PDI,0))
. S PSJVNM=$P(PSJND,"^"),PSJDNS=$P(PSJND,"^",2),PSJVP=$P(PSJND,"^",3)
. S PDJ=0 F S PDJ=$O(PDCL(PDI,PDJ)) Q:'PDJ D
.. S PSJDNM=$P($$SITE^VASITE(,PDJ),"^",3)
.. S PDK=0 F S PDK=$O(PDCL(PDI,PDJ,PDK)) Q:'PDK D APPT
Q
;
APPT ;
K ^TMP($J,"SDAMA202")
S PSJOR=PDK,PSJORN=$P(^SC(PDK,0),"^")
S DTP=PDCL(PDI,PDJ,PDK)
S EDT=DT
I DTP S X1=DT,X2=+DTP D C^%DTC S EDT=X
D GETPLIST^SDAMA202(PDK,"1;4","",DT,EDT)
Q:'$D(^TMP($J,"SDAMA202"))
K APDTM,CLNM,PSJXCL
S PDA=0 F S PDA=$O(^TMP($J,"SDAMA202","GETPLIST",PDA)) Q:'PDA D
. S PSJDTM=+^TMP($J,"SDAMA202","GETPLIST",PDA,1)
. S DFN=+^TMP($J,"SDAMA202","GETPLIST",PDA,4)
. Q:$P($G(^DPT(DFN,.1)),"^")]""&($P(^PS(58.7,PDI,0),"^",6)'="Y")
. K NSEG N ZZ1,XX,FTS S (ZZ1,FTS)="",PSJNIP=0
. I $P($G(^DPT(DFN,.1)),"^")]"" D
.. D IN5^VADPT
.. N PSJQ,PSJWD,PSJRBD
.. S PSJWD=$P(VAIP(5),"^",2),PSJRBD=$P(VAIP(6),"^",2)
.. S PSJQ=$$CHKPD^PSJPDCL(PSJWD,PSJRBD)
.. I 'PSJQ S PSJNIP=1 Q
.. S FTS=$P(VAIP(8),"^")_NECH_$P(VAIP(8),"^",2)
.. S XX=0 F S XX=$O(PSJQ(XX)) Q:'XX D
... I XX=PDI,$P(PSJQ(XX),"^",2)'="" S ZZ1=$P(PSJQ(XX),"^",2)
... I XX'=PDI S PSJNIP=1
... I $G(PSJXCL(PDI)) S PSJNIP=0
. S SEQ=0 D SRBLD^PSJPDCLA M HL=NHL N ZZ2 S ZZ2=$S($P(DTP,"^",2)'="":$P(DTP,"^",2),1:"")
. S SEQ=SEQ+1,NSEG(SEQ)="ZZZ"_HL("FS")_$S(ZZ1'="":ZZ1,1:"")_HL("FS")_ZZ2_HL("FS")_FTS
. K HLP,HLA,PSJSND S HLP="",HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
. N XX S XX=PDI D PV19 M HLA("HLS")=NSEG
. D GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
. D LOG^PSJPADE
Q
;
ALLCLN ;
N ND S Z=0 F S Z=$O(^SC(Z)) Q:'Z D
.S ND=^SC(Z,0) Q:$P(ND,"^",3)'="C" Q:$P(ND,"^",15)'=J
.I $D(^SC(Z,"I")) S X=$G(^SC(Z,"I")) I $P(X,"^"),$P(X,"^",2)'>$P(X,"^") Q
.S PDCL(I,J,Z)=DTP_$S(SA]"":"^"_SA,1:"")
Q
;
CLARR ;
S Z=0,SA=""
F S Z=$O(^PS(58.7,I,"DIV",J,"CL",Z)) Q:'Z S K=^PS(58.7,I,"DIV",J,"CL",Z,0) D:$P(K,"^",3)="Y"
. S SA=$P(K,"^",2)
. S:SA SA=$P($G(^PS(58.71,SA,0)),"^")
. S PDCLA(I,J,+K)=DTP_$S(SA]"":"^"_SA,1:"")
S Z=0
F S Z=$O(^PS(58.7,I,"DIV",J,"PCG",Z)) Q:'Z D:$P($G(^PS(58.7,I,"DIV",J,"PCG",Z,2)),"^")="Y"
. S SA=$P($G(^PS(58.7,I,"DIV",J,"PCG",Z,0)),"^",2)
. S:SA SA=$P($G(^PS(58.71,SA,0)),"^")
. S X=0 F S X=$O(^PS(58.7,I,"DIV",J,"PCG",Z,1,X)) Q:'X D
.. S K=+$G(^PS(58.7,I,"DIV",J,"PCG",Z,1,X,0))
.. I '$D(PDCLA(I,J,K)) S PDCLA(I,J,K)=DTP_$S(SA]"":"^"_SA,1:"")
S Z=0
F S Z=$O(^PS(58.7,I,"DIV",J,"VCG",Z)) Q:'Z S X=^PS(58.7,I,"DIV",J,"VCG",Z,0) D:$P(X,"^",3)="Y"
. S SA=$P(X,"^",2) S:SA SA=$P($G(^PS(58.71,SA,0)),"^")
. S Y=0 F S Y=$O(^PS(57.8,+X,1,Y)) Q:'Y D
.. S K=+^(Y,0) S:'$D(PDCLA(I,J,K)) PDCLA(I,J,K)=DTP_$S(SA]"":"^"_SA,1:"")
S Z=0,L=""
F S Z=$O(^PS(58.7,I,"DIV",J,"WCN",Z)) Q:'Z S X=^PS(58.7,I,"DIV",J,"WCN",Z,0) D:$P(X,"^",3)="Y"
. S SA=$P(X,"^",2) S:SA SA=$P($G(^PS(58.71,SA,0)),"^")
. S Y=$P(X,"^"),P=$E(X,1,$L(Y)-1) F S P=$O(^SC("B",P)) Q:P="" D
.. Q:($E(P,1,$L(Y))'=Y) ;p415
.. S K=$O(^SC("B",P,0)),L=$G(^SC(K,0)) Q:$P(L,"^",3)'="C" Q:$P(L,"^",15)'=J
.. S:'$D(PDCLA(I,J,K)) PDCLA(I,J,K)=DTP_$S(SA]"":"^"_SA,1:"")
Q
;
PV19 ;
N NC,NDFN,NCLI,N19,NSA,NS,NWDI,NQ
S (NSA,N19)="",(NQ,NC)=0,NS=$E(HL("ECH"),1),PDL(10)=XX,PDL(4)=HL("ETN")
S:ZZ2]"" (NSA,PDL(12))=$O(^PS(58.71,"B",ZZ2,0))
S:ZZ1]"" PDL(11)=$O(^PS(58.71,"B",ZZ1,""))
F S NC=$O(NSEG(NC)) Q:'NC D Q:NQ
. I $E(NSEG(NC),1,3)="PID" S (NDFN,PDL(1))=+$P(NSEG(NC),HL("FS"),4) Q
. I $E(NSEG(NC),1,3)="PV1" D S NQ=1 Q
.. I $P(NSEG(NC),HL("FS"),12)]"" D
... S NCLI=$P($P(NSEG(NC),HL("FS"),12),NS,2)
... S:'NCLI NCLI=$O(^SC("B",$P($P(NSEG(NC),HL("FS"),12),NS),0))
... S:NCLI PDL(5)=+$P($G(^SC(NCLI,0)),"^",15)
... S N19=NDFN_"-"_$S(NSA]"":NSA_"S",1:NCLI),PDL(9)=N19 S:NCLI PDL(8)=NCLI
... S $P(NSEG(NC),HL("FS"),20)=N19
.. I $P(NSEG(NC),HL("FS"),4)]"" D
... S NWDI=$O(^DIC(42,"B",$P($P(NSEG(NC),HL("FS"),4),NS),0))
... I NWDI S PDL(7)=NWDI S:'$G(PDL(5)) PDL(5)=+$P($G(^DIC(42,NWDI,0)),"^",11)
.. S:$P(NSEG(NC),HL("FS"),51)]"" PDL(6)=$P(NSEG(NC),HL("FS"),51)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJPDAPP 5329 printed May 06, 2022@00:54:16 Page 2
PSJPDAPP ;BIR/MHA - SEND APPOINTMENTS TO PADE ;11/27/15
+1 ;;5.0;INPATIENT MEDICATIONS;**317,389,415**;16 DEC 97;Build 3
+2 ;Reference to ^PS(55 is supported by DBIA 2191
+3 ;Reference to ^ORD(101 supported by DBIA 872
+4 ;Reference to GETPLIST^SDAMA202 supported by DBIA 3869
+5 ;Reference to ^SC supported by DBIA 10040
+6 ;Reference to ^DPT supported by DBIA 10035
+7 QUIT
+8 ;
EN ;
+1 NEW PDA,PDCL,PDCLA,PDI,PDJ,PDK,PSJAP,PSJCLPD,PSJPDNM,PSJDIV,DTP,SA,SEQ,I,J,K,L,P,X,Y,Z,PSJNIP,X1,X2
+2 SET (DTP,PSJAP,I)=0
+3 FOR
SET I=$ORDER(^PS(58.7,I))
if 'I
QUIT
SET J=$$PDACT^PSJPDCLA(I)
+4 if 'PSJAP
QUIT
+5 SET I=0
FOR
SET I=$ORDER(PSJAP(I))
if 'I
QUIT
Begin DoDot:1
+6 SET DTP=+$GET(^PS(58.7,I,1))
+7 SET J=0
FOR
SET J=$ORDER(^PS(58.7,I,"DIV",J))
if 'J
QUIT
Begin DoDot:2
+8 SET Y=$GET(^PS(58.7,I,"DIV",J,0))
IF Y=""!($PIECE(Y,"^",2)&($PIECE(Y,"^",2)<DT))
QUIT
+9 SET SA=""
+10 ;send appt for all clinics
IF $PIECE(Y,"^",9)="Y"
if $PIECE(Y,"^",4)
SET SA=$PIECE($GET(^PS(58.71,$PIECE(Y,"^",4),0)),"^")
DO ALLCLN
+11 DO CLARR
End DoDot:2
End DoDot:1
+12 MERGE PDCL=PDCLA
+13 if '$DATA(PDCL)
QUIT
+14 NEW SNM,CNM
SET SNM="PSJ SIU-S12 SERVER"
SET CNM="PSJ SIU-S12 CLIENT"
+15 IF '$ORDER(^ORD(101,"B",SNM,0))!('$ORDER(^ORD(101,"B",CNM,0)))
QUIT
+16 NEW NHL
DO INIT^HLFNC2(SNM,.NHL)
if $DATA(NHL)=1
QUIT
+17 NEW NFS,NECH,HL,HLFS,NSEG,EDT,APT,DFN,PSJDTM,PSJND,PSJVP,PSJVNM,PSJDNS,PSJDNM,PSJOR,PSJORN
+18 MERGE HL=NHL
SET (NFS,HLFS)=HL("FS")
SET NECH=$EXTRACT(HL("ECH"),1)
+19 SET PDI=0
FOR
SET PDI=$ORDER(PDCL(PDI))
if 'PDI
QUIT
Begin DoDot:1
+20 SET PSJND=$GET(^PS(58.7,PDI,0))
+21 SET PSJVNM=$PIECE(PSJND,"^")
SET PSJDNS=$PIECE(PSJND,"^",2)
SET PSJVP=$PIECE(PSJND,"^",3)
+22 SET PDJ=0
FOR
SET PDJ=$ORDER(PDCL(PDI,PDJ))
if 'PDJ
QUIT
Begin DoDot:2
+23 SET PSJDNM=$PIECE($$SITE^VASITE(,PDJ),"^",3)
+24 SET PDK=0
FOR
SET PDK=$ORDER(PDCL(PDI,PDJ,PDK))
if 'PDK
QUIT
DO APPT
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
APPT ;
+1 KILL ^TMP($JOB,"SDAMA202")
+2 SET PSJOR=PDK
SET PSJORN=$PIECE(^SC(PDK,0),"^")
+3 SET DTP=PDCL(PDI,PDJ,PDK)
+4 SET EDT=DT
+5 IF DTP
SET X1=DT
SET X2=+DTP
DO C^%DTC
SET EDT=X
+6 DO GETPLIST^SDAMA202(PDK,"1;4","",DT,EDT)
+7 if '$DATA(^TMP($JOB,"SDAMA202"))
QUIT
+8 KILL APDTM,CLNM,PSJXCL
+9 SET PDA=0
FOR
SET PDA=$ORDER(^TMP($JOB,"SDAMA202","GETPLIST",PDA))
if 'PDA
QUIT
Begin DoDot:1
+10 SET PSJDTM=+^TMP($JOB,"SDAMA202","GETPLIST",PDA,1)
+11 SET DFN=+^TMP($JOB,"SDAMA202","GETPLIST",PDA,4)
+12 if $PIECE($GET(^DPT(DFN,.1)),"^")]""&($PIECE(^PS(58.7,PDI,0),"^",6)'="Y")
QUIT
+13 KILL NSEG
NEW ZZ1,XX,FTS
SET (ZZ1,FTS)=""
SET PSJNIP=0
+14 IF $PIECE($GET(^DPT(DFN,.1)),"^")]""
Begin DoDot:2
+15 DO IN5^VADPT
+16 NEW PSJQ,PSJWD,PSJRBD
+17 SET PSJWD=$PIECE(VAIP(5),"^",2)
SET PSJRBD=$PIECE(VAIP(6),"^",2)
+18 SET PSJQ=$$CHKPD^PSJPDCL(PSJWD,PSJRBD)
+19 IF 'PSJQ
SET PSJNIP=1
QUIT
+20 SET FTS=$PIECE(VAIP(8),"^")_NECH_$PIECE(VAIP(8),"^",2)
+21 SET XX=0
FOR
SET XX=$ORDER(PSJQ(XX))
if 'XX
QUIT
Begin DoDot:3
+22 IF XX=PDI
IF $PIECE(PSJQ(XX),"^",2)'=""
SET ZZ1=$PIECE(PSJQ(XX),"^",2)
+23 IF XX'=PDI
SET PSJNIP=1
+24 IF $GET(PSJXCL(PDI))
SET PSJNIP=0
End DoDot:3
End DoDot:2
+25 SET SEQ=0
DO SRBLD^PSJPDCLA
MERGE HL=NHL
NEW ZZ2
SET ZZ2=$SELECT($PIECE(DTP,"^",2)'="":$PIECE(DTP,"^",2),1:"")
+26 SET SEQ=SEQ+1
SET NSEG(SEQ)="ZZZ"_HL("FS")_$SELECT(ZZ1'="":ZZ1,1:"")_HL("FS")_ZZ2_HL("FS")_FTS
+27 KILL HLP,HLA,PSJSND
SET HLP=""
SET HLP("SUBSCRIBER")="^^^^~"_PSJDNS_":"_PSJVP_"~DNS"
+28 NEW XX
SET XX=PDI
DO PV19
MERGE HLA("HLS")=NSEG
+29 DO GENERATE^HLMA(SNM,"LM",1,.PSJSND,"",.HLP)
+30 DO LOG^PSJPADE
End DoDot:1
+31 QUIT
+32 ;
ALLCLN ;
+1 NEW ND
SET Z=0
FOR
SET Z=$ORDER(^SC(Z))
if 'Z
QUIT
Begin DoDot:1
+2 SET ND=^SC(Z,0)
if $PIECE(ND,"^",3)'="C"
QUIT
if $PIECE(ND,"^",15)'=J
QUIT
+3 IF $DATA(^SC(Z,"I"))
SET X=$GET(^SC(Z,"I"))
IF $PIECE(X,"^")
IF $PIECE(X,"^",2)'>$PIECE(X,"^")
QUIT
+4 SET PDCL(I,J,Z)=DTP_$SELECT(SA]"":"^"_SA,1:"")
End DoDot:1
+5 QUIT
+6 ;
CLARR ;
+1 SET Z=0
SET SA=""
+2 FOR
SET Z=$ORDER(^PS(58.7,I,"DIV",J,"CL",Z))
if 'Z
QUIT
SET K=^PS(58.7,I,"DIV",J,"CL",Z,0)
if $PIECE(K,"^",3)="Y"
Begin DoDot:1
+3 SET SA=$PIECE(K,"^",2)
+4 if SA
SET SA=$PIECE($GET(^PS(58.71,SA,0)),"^")
+5 SET PDCLA(I,J,+K)=DTP_$SELECT(SA]"":"^"_SA,1:"")
End DoDot:1
+6 SET Z=0
+7 FOR
SET Z=$ORDER(^PS(58.7,I,"DIV",J,"PCG",Z))
if 'Z
QUIT
if $PIECE($GET(^PS(58.7,I,"DIV",J,"PCG",Z,2)),"^")="Y"
Begin DoDot:1
+8 SET SA=$PIECE($GET(^PS(58.7,I,"DIV",J,"PCG",Z,0)),"^",2)
+9 if SA
SET SA=$PIECE($GET(^PS(58.71,SA,0)),"^")
+10 SET X=0
FOR
SET X=$ORDER(^PS(58.7,I,"DIV",J,"PCG",Z,1,X))
if 'X
QUIT
Begin DoDot:2
+11 SET K=+$GET(^PS(58.7,I,"DIV",J,"PCG",Z,1,X,0))
+12 IF '$DATA(PDCLA(I,J,K))
SET PDCLA(I,J,K)=DTP_$SELECT(SA]"":"^"_SA,1:"")
End DoDot:2
End DoDot:1
+13 SET Z=0
+14 FOR
SET Z=$ORDER(^PS(58.7,I,"DIV",J,"VCG",Z))
if 'Z
QUIT
SET X=^PS(58.7,I,"DIV",J,"VCG",Z,0)
if $PIECE(X,"^",3)="Y"
Begin DoDot:1
+15 SET SA=$PIECE(X,"^",2)
if SA
SET SA=$PIECE($GET(^PS(58.71,SA,0)),"^")
+16 SET Y=0
FOR
SET Y=$ORDER(^PS(57.8,+X,1,Y))
if 'Y
QUIT
Begin DoDot:2
+17 SET K=+^(Y,0)
if '$DATA(PDCLA(I,J,K))
SET PDCLA(I,J,K)=DTP_$SELECT(SA]"":"^"_SA,1:"")
End DoDot:2
End DoDot:1
+18 SET Z=0
SET L=""
+19 FOR
SET Z=$ORDER(^PS(58.7,I,"DIV",J,"WCN",Z))
if 'Z
QUIT
SET X=^PS(58.7,I,"DIV",J,"WCN",Z,0)
if $PIECE(X,"^",3)="Y"
Begin DoDot:1
+20 SET SA=$PIECE(X,"^",2)
if SA
SET SA=$PIECE($GET(^PS(58.71,SA,0)),"^")
+21 SET Y=$PIECE(X,"^")
SET P=$EXTRACT(X,1,$LENGTH(Y)-1)
FOR
SET P=$ORDER(^SC("B",P))
if P=""
QUIT
Begin DoDot:2
+22 ;p415
if ($EXTRACT(P,1,$LENGTH(Y))'=Y)
QUIT
+23 SET K=$ORDER(^SC("B",P,0))
SET L=$GET(^SC(K,0))
if $PIECE(L,"^",3)'="C"
QUIT
if $PIECE(L,"^",15)'=J
QUIT
+24 if '$DATA(PDCLA(I,J,K))
SET PDCLA(I,J,K)=DTP_$SELECT(SA]"":"^"_SA,1:"")
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
PV19 ;
+1 NEW NC,NDFN,NCLI,N19,NSA,NS,NWDI,NQ
+2 SET (NSA,N19)=""
SET (NQ,NC)=0
SET NS=$EXTRACT(HL("ECH"),1)
SET PDL(10)=XX
SET PDL(4)=HL("ETN")
+3 if ZZ2]""
SET (NSA,PDL(12))=$ORDER(^PS(58.71,"B",ZZ2,0))
+4 if ZZ1]""
SET PDL(11)=$ORDER(^PS(58.71,"B",ZZ1,""))
+5 FOR
SET NC=$ORDER(NSEG(NC))
if 'NC
QUIT
Begin DoDot:1
+6 IF $EXTRACT(NSEG(NC),1,3)="PID"
SET (NDFN,PDL(1))=+$PIECE(NSEG(NC),HL("FS"),4)
QUIT
+7 IF $EXTRACT(NSEG(NC),1,3)="PV1"
Begin DoDot:2
+8 IF $PIECE(NSEG(NC),HL("FS"),12)]""
Begin DoDot:3
+9 SET NCLI=$PIECE($PIECE(NSEG(NC),HL("FS"),12),NS,2)
+10 if 'NCLI
SET NCLI=$ORDER(^SC("B",$PIECE($PIECE(NSEG(NC),HL("FS"),12),NS),0))
+11 if NCLI
SET PDL(5)=+$PIECE($GET(^SC(NCLI,0)),"^",15)
+12 SET N19=NDFN_"-"_$SELECT(NSA]"":NSA_"S",1:NCLI)
SET PDL(9)=N19
if NCLI
SET PDL(8)=NCLI
+13 SET $PIECE(NSEG(NC),HL("FS"),20)=N19
End DoDot:3
+14 IF $PIECE(NSEG(NC),HL("FS"),4)]""
Begin DoDot:3
+15 SET NWDI=$ORDER(^DIC(42,"B",$PIECE($PIECE(NSEG(NC),HL("FS"),4),NS),0))
+16 IF NWDI
SET PDL(7)=NWDI
if '$GET(PDL(5))
SET PDL(5)=+$PIECE($GET(^DIC(42,NWDI,0)),"^",11)
End DoDot:3
+17 if $PIECE(NSEG(NC),HL("FS"),51)]""
SET PDL(6)=$PIECE(NSEG(NC),HL("FS"),51)
End DoDot:2
SET NQ=1
QUIT
End DoDot:1
if NQ
QUIT
+18 QUIT
+19 ;
