PSOPKIV2 ;BIR/MHA - Dig Signed Pending order Auto-DC message ;08/17/11
;;7.0;OUTPATIENT PHARMACY;**391,495,504**;DEC 1997;Build 15
;
ADCMAIL ;
N XX,QQ,ZZ S ZZ="PSOPODC" S:'$G(DFN) DFN=PSODFN D ^VADPT,ADD^VADPT
K ^TMP(ZZ,$J)
S XMSUB=$P(^PS(59,PSOSITE,0),"^",6)_" - DIGITALLY SIGNED "_$S($P(OR0,"^",3)="RNW":"RE",1:"")_"NEW ORDER AUTO DISCONTINUED",XMDUZ=.5
S LC=1,^TMP(ZZ,$J,LC)="",LC=LC+1
S ^TMP(ZZ,$J,LC)="Following order was auto discontinued when finishing a pending order due to "_$P(PKIE,": ",2),LC=LC+1
S ^TMP(ZZ,$J,LC)="",LC=LC+1
S ^TMP(ZZ,$J,LC)="Division : "_$P(^PS(59,PSOSITE,0),"^"),LC=LC+1
S ^TMP(ZZ,$J,LC)="CPRS Order # : "_$P(OR0,"^"),LC=LC+1
S ^TMP(ZZ,$J,LC)="Issue Date : "_PSONEW("ISSUE DATE"),LC=LC+1
S ^TMP(ZZ,$J,LC)="Patient : "_$P(^DPT(DFN,0),U)_" ("_$G(VA("BID"))_")",LC=LC+1
;S ^TMP(ZZ,$J,LC)="Address : ",LC=LC+1
D PATAD
S ^TMP(ZZ,$J,LC)="Drug : "_$G(PSODRUG("NAME")),LC=LC+1
S QQ=PSONEW("DOSE",1) S:PSONEW("UNITS",1) QQ=QQ_"("_$P(^PS(50.607,PSONEW("UNITS",1),0),"^")_")"
I $O(PSONEW("DOSE",1)) S XX=1 F S XX=$O(PSONEW("DOSE",XX)) Q:'XX D
.S QQ=QQ_","_PSONEW("DOSE",XX)
.S:PSONEW("UNITS",XX) QQ=QQ_"("_$P(^PS(50.607,PSONEW("UNITS",XX),0),"^")_")"
S ^TMP(ZZ,$J,LC)="Dosage Ordered: "_QQ
S LC=LC+1
S ^TMP(ZZ,$J,LC)="Dosage Form : "_PSONEW("NOUN",1),LC=LC+1
S ^TMP(ZZ,$J,LC)="Quantity : "_PSONEW("QTY")
N TLC K TMP("ZZ") S XX=0,TLC=1,TMP("ZZ",1,0)="SIG : "
F S XX=$O(^PS(52.41,ORD,"SIG",XX)) Q:'XX D
.S QQ=^PS(52.41,ORD,"SIG",XX,0)
.D WORDWRAP^PSOUTLA2(QQ,.TLC,$NA(TMP("ZZ")),15)
S XX=0 F S XX=$O(TMP("ZZ",XX)) Q:'XX S ^TMP(ZZ,$J,LC+1)=TMP("ZZ",XX,0)
S LC=LC+1
S ^TMP(ZZ,$J,LC)="Provider : "_PSONEW("PROVIDER NAME"),LC=LC+1
D PRV
S LC=LC+1,^TMP(ZZ,$J,LC)=""
I $G(PKIOR)=16 D MISMCH
D MGRP
S XMY(DUZ)="",XMTEXT="^TMP(ZZ,$J," N DIFROM D ^XMD K XMDUZ,XMTEXT,XMSUB
K ^TMP(ZZ,$J)
Q
;
MISMCH ;Reason for mis-match
N XX,XY,XZ,X1,X2,XM,PSOARY,HASH
S HASH=$$HSHCHK^PSOPKIV1(.PSOARY,ORD) I HASH'=-1 Q
I $O(PSOARY(""))="" Q
;I $G(PSOARY)'=-1 Q
S $P(XZ," ",80)="",LC=LC+1
S ^TMP(ZZ,$J,LC)="Differences in CPRS and Pharmacy Pending File",LC=LC+1,^TMP(ZZ,$J,LC)=""
S LC=LC+1,^TMP(ZZ,$J,LC)="Data Name CPRS File Pharmacy Pending File"
S LC=LC+1,^TMP(ZZ,$J,LC)="--------- --------- ---------------------"
S LC=LC+1,XX=""
F S XX=$O(PSOARY(XX)) Q:XX="" D
.S XY=PSOARY(XX),LC=LC+1
.S X1=$P(XY,"^"),X2=$P(XY,"^",2)
.S XM=$S($L(X1)>$L(X2):X1,1:X2),STR=""
.F I=0:1:$L(XM) Q:$E(XM,28*I,$L(XM))="" D
.. S ^TMP(ZZ,$J,LC)=$S(I=0:$E(XX,1,18),1:"")_$$BLNK(19,$S(I=0:$E(XX,1,18),1:""))_$E(X1,(28*I),(28*I+28))_$$BLNK(29,$S($E(X1,(28*I),(28*I+28))]"":$E(X1,(28*I),(28*I+28)),1:""))_$E(X2,(28*I),(28*I+28)),LC=LC+1
Q
;
BLNK(X,STR) ;blank spaces
N XZ,SP
Q:X="" ""
S $P(XZ," ",80)="",SP=X-$L(STR)
Q $E(XZ,1,SP)
MGRP ;
N MDUZ S MDUZ=0 F S MDUZ=$O(^XUSEC("PSDMGR",MDUZ)) Q:MDUZ'>0 S XMY(MDUZ)=""
Q
;
PRV ;
N DEA,VADD,PRV,DRG,ORN
S PRV=$G(PSONEW("PROVIDER")),DRG=$G(PSODRUG("IEN")),ORN=$P(OR0,"^")
I PRV="" Q
S DEA=$$DEA^XUSER(0,PRV)
S DEA=$S(DEA["-":"VA# : ",1:"DEA# : ")_DEA
S ^TMP(ZZ,$J,LC)=DEA
I $$DETOX^PSSOPKI(DRG),$$RXDETOX^PSOUTIL(,+$G(ORN))'="" S ^TMP(ZZ,$J,LC)=^TMP(ZZ,$J,LC)_" DETOX#: "_$$RXDETOX^PSOUTIL(,+$G(ORN))
D PRVAD
I $G(VADD(1))]"" D
.S LC=LC+1,^TMP(ZZ,$J,LC)="Site Address : "_VADD(1)
.S:VADD(2)'="" LC=LC+1,^TMP(ZZ,$J,LC)=" "_VADD(2)
.S:VADD(3)'="" LC=LC+1,^TMP(ZZ,$J,LC)=" "_VADD(3)
Q
;
PRVAD ;
K ^TMP($J,"ORDEA")
D ARCHIVE^ORDEA(ORN)
I $D(^TMP($J,"ORDEA",ORN,3)) S VADD=^(3) D
.S VADD(1)=$P(VADD,"^",2),VADD(2)=$P(VADD,"^",3),VADD(3)=$P(VADD,"^",4)_", "_$P(VADD,"^",5)_" "_$P($P(VADD,"^",6),"-")
K ^TMP($J,"ORDEA")
Q
;
PATAD ;
N PSOBADR,PSOTEMP,PSOFORGN,I,T
S PSOBADR=0,PSOTEMP=0,XX=0
S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOFORGN=1
I 'PSOFORGN S PSOBADR=$$BADADR^DGUTL3(DFN)
I 'PSOFORGN,PSOBADR S PSOTEMP=$$CHKTEMP^PSOBAI(DFN)
F I=1:1:3 I $G(VAPA(I))]"" D
. S T="" I I=1,'PSOFORGN,PSOBADR,'$G(PSOTEMP) S T="** BAD ADDRESS INDICATED **"
. I I=1,T="",PSOFORGN S T="*** FOREIGN ADDRESS ***"
. I T="" I 'PSOFORGN I 'PSOBADR!$G(PSOTEMP) S T=$G(VAPA(I))
. I I=1,T]"" S ^TMP(ZZ,$J,LC)="Address : "_T,LC=LC+1
. I I>1,T]"" S ^TMP(ZZ,$J,LC)=" "_T,LC=LC+1
S I=+$G(VAPA(5)) I I S I=$S($D(^DIC(5,I,0)):$P(^(0),"^",2),1:"UNKNOWN")
S T="" I 'PSOFORGN I 'PSOBADR!$G(PSOTEMP) S T=$G(VAPA(4))_", "_I_" "_$S($G(VAPA(11)):$P(VAPA(11),"^",2),1:$G(VAPA(6)))
S:T]"" ^TMP(ZZ,$J,LC)=" "_T,LC=LC+1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPKIV2 4739 printed Nov 22, 2024@17:42:42 Page 2
PSOPKIV2 ;BIR/MHA - Dig Signed Pending order Auto-DC message ;08/17/11
+1 ;;7.0;OUTPATIENT PHARMACY;**391,495,504**;DEC 1997;Build 15
+2 ;
ADCMAIL ;
+1 NEW XX,QQ,ZZ
SET ZZ="PSOPODC"
if '$GET(DFN)
SET DFN=PSODFN
DO ^VADPT
DO ADD^VADPT
+2 KILL ^TMP(ZZ,$JOB)
+3 SET XMSUB=$PIECE(^PS(59,PSOSITE,0),"^",6)_" - DIGITALLY SIGNED "_$SELECT($PIECE(OR0,"^",3)="RNW":"RE",1:"")_"NEW ORDER AUTO DISCONTINUED"
SET XMDUZ=.5
+4 SET LC=1
SET ^TMP(ZZ,$JOB,LC)=""
SET LC=LC+1
+5 SET ^TMP(ZZ,$JOB,LC)="Following order was auto discontinued when finishing a pending order due to "_$PIECE(PKIE,": ",2)
SET LC=LC+1
+6 SET ^TMP(ZZ,$JOB,LC)=""
SET LC=LC+1
+7 SET ^TMP(ZZ,$JOB,LC)="Division : "_$PIECE(^PS(59,PSOSITE,0),"^")
SET LC=LC+1
+8 SET ^TMP(ZZ,$JOB,LC)="CPRS Order # : "_$PIECE(OR0,"^")
SET LC=LC+1
+9 SET ^TMP(ZZ,$JOB,LC)="Issue Date : "_PSONEW("ISSUE DATE")
SET LC=LC+1
+10 SET ^TMP(ZZ,$JOB,LC)="Patient : "_$PIECE(^DPT(DFN,0),U)_" ("_$GET(VA("BID"))_")"
SET LC=LC+1
+11 ;S ^TMP(ZZ,$J,LC)="Address : ",LC=LC+1
+12 DO PATAD
+13 SET ^TMP(ZZ,$JOB,LC)="Drug : "_$GET(PSODRUG("NAME"))
SET LC=LC+1
+14 SET QQ=PSONEW("DOSE",1)
if PSONEW("UNITS",1)
SET QQ=QQ_"("_$PIECE(^PS(50.607,PSONEW("UNITS",1),0),"^")_")"
+15 IF $ORDER(PSONEW("DOSE",1))
SET XX=1
FOR
SET XX=$ORDER(PSONEW("DOSE",XX))
if 'XX
QUIT
Begin DoDot:1
+16 SET QQ=QQ_","_PSONEW("DOSE",XX)
+17 if PSONEW("UNITS",XX)
SET QQ=QQ_"("_$PIECE(^PS(50.607,PSONEW("UNITS",XX),0),"^")_")"
End DoDot:1
+18 SET ^TMP(ZZ,$JOB,LC)="Dosage Ordered: "_QQ
+19 SET LC=LC+1
+20 SET ^TMP(ZZ,$JOB,LC)="Dosage Form : "_PSONEW("NOUN",1)
SET LC=LC+1
+21 SET ^TMP(ZZ,$JOB,LC)="Quantity : "_PSONEW("QTY")
+22 NEW TLC
KILL TMP("ZZ")
SET XX=0
SET TLC=1
SET TMP("ZZ",1,0)="SIG : "
+23 FOR
SET XX=$ORDER(^PS(52.41,ORD,"SIG",XX))
if 'XX
QUIT
Begin DoDot:1
+24 SET QQ=^PS(52.41,ORD,"SIG",XX,0)
+25 DO WORDWRAP^PSOUTLA2(QQ,.TLC,$NAME(TMP("ZZ")),15)
End DoDot:1
+26 SET XX=0
FOR
SET XX=$ORDER(TMP("ZZ",XX))
if 'XX
QUIT
SET ^TMP(ZZ,$JOB,LC+1)=TMP("ZZ",XX,0)
+27 SET LC=LC+1
+28 SET ^TMP(ZZ,$JOB,LC)="Provider : "_PSONEW("PROVIDER NAME")
SET LC=LC+1
+29 DO PRV
+30 SET LC=LC+1
SET ^TMP(ZZ,$JOB,LC)=""
+31 IF $GET(PKIOR)=16
DO MISMCH
+32 DO MGRP
+33 SET XMY(DUZ)=""
SET XMTEXT="^TMP(ZZ,$J,"
NEW DIFROM
DO ^XMD
KILL XMDUZ,XMTEXT,XMSUB
+34 KILL ^TMP(ZZ,$JOB)
+35 QUIT
+36 ;
MISMCH ;Reason for mis-match
+1 NEW XX,XY,XZ,X1,X2,XM,PSOARY,HASH
+2 SET HASH=$$HSHCHK^PSOPKIV1(.PSOARY,ORD)
IF HASH'=-1
QUIT
+3 IF $ORDER(PSOARY(""))=""
QUIT
+4 ;I $G(PSOARY)'=-1 Q
+5 SET $PIECE(XZ," ",80)=""
SET LC=LC+1
+6 SET ^TMP(ZZ,$JOB,LC)="Differences in CPRS and Pharmacy Pending File"
SET LC=LC+1
SET ^TMP(ZZ,$JOB,LC)=""
+7 SET LC=LC+1
SET ^TMP(ZZ,$JOB,LC)="Data Name CPRS File Pharmacy Pending File"
+8 SET LC=LC+1
SET ^TMP(ZZ,$JOB,LC)="--------- --------- ---------------------"
+9 SET LC=LC+1
SET XX=""
+10 FOR
SET XX=$ORDER(PSOARY(XX))
if XX=""
QUIT
Begin DoDot:1
+11 SET XY=PSOARY(XX)
SET LC=LC+1
+12 SET X1=$PIECE(XY,"^")
SET X2=$PIECE(XY,"^",2)
+13 SET XM=$SELECT($LENGTH(X1)>$LENGTH(X2):X1,1:X2)
SET STR=""
+14 FOR I=0:1:$LENGTH(XM)
if $EXTRACT(XM,28*I,$LENGTH(XM))=""
QUIT
Begin DoDot:2
+15 SET ^TMP(ZZ,$JOB,LC)=$SELECT(I=0:$EXTRACT(XX,1,18),1:"")_$$BLNK(19,$SELECT(I=0:$EXTRACT(XX,1,18),1:""))_$EXTRACT(X1,(28*I),(28*I+28))_$$BLNK(29,$SELECT($EXTRACT(X1,(28*I),(28*I+28))]"":$EXTRACT(X1,(28*I),(28*I+28)),1:""))_$EXTRA
CT(X2,(28*I),(28*I+28))
SET LC=LC+1
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
BLNK(X,STR) ;blank spaces
+1 NEW XZ,SP
+2 if X=""
QUIT ""
+3 SET $PIECE(XZ," ",80)=""
SET SP=X-$LENGTH(STR)
+4 QUIT $EXTRACT(XZ,1,SP)
MGRP ;
+1 NEW MDUZ
SET MDUZ=0
FOR
SET MDUZ=$ORDER(^XUSEC("PSDMGR",MDUZ))
if MDUZ'>0
QUIT
SET XMY(MDUZ)=""
+2 QUIT
+3 ;
PRV ;
+1 NEW DEA,VADD,PRV,DRG,ORN
+2 SET PRV=$GET(PSONEW("PROVIDER"))
SET DRG=$GET(PSODRUG("IEN"))
SET ORN=$PIECE(OR0,"^")
+3 IF PRV=""
QUIT
+4 SET DEA=$$DEA^XUSER(0,PRV)
+5 SET DEA=$SELECT(DEA["-":"VA# : ",1:"DEA# : ")_DEA
+6 SET ^TMP(ZZ,$JOB,LC)=DEA
+7 IF $$DETOX^PSSOPKI(DRG)
IF $$RXDETOX^PSOUTIL(,+$GET(ORN))'=""
SET ^TMP(ZZ,$JOB,LC)=^TMP(ZZ,$JOB,LC)_" DETOX#: "_$$RXDETOX^PSOUTIL(,+$GET(ORN))
+8 DO PRVAD
+9 IF $GET(VADD(1))]""
Begin DoDot:1
+10 SET LC=LC+1
SET ^TMP(ZZ,$JOB,LC)="Site Address : "_VADD(1)
+11 if VADD(2)'=""
SET LC=LC+1
SET ^TMP(ZZ,$JOB,LC)=" "_VADD(2)
+12 if VADD(3)'=""
SET LC=LC+1
SET ^TMP(ZZ,$JOB,LC)=" "_VADD(3)
End DoDot:1
+13 QUIT
+14 ;
PRVAD ;
+1 KILL ^TMP($JOB,"ORDEA")
+2 DO ARCHIVE^ORDEA(ORN)
+3 IF $DATA(^TMP($JOB,"ORDEA",ORN,3))
SET VADD=^(3)
Begin DoDot:1
+4 SET VADD(1)=$PIECE(VADD,"^",2)
SET VADD(2)=$PIECE(VADD,"^",3)
SET VADD(3)=$PIECE(VADD,"^",4)_", "_$PIECE(VADD,"^",5)_" "_$PIECE($PIECE(VADD,"^",6),"-")
End DoDot:1
+5 KILL ^TMP($JOB,"ORDEA")
+6 QUIT
+7 ;
PATAD ;
+1 NEW PSOBADR,PSOTEMP,PSOFORGN,I,T
+2 SET PSOBADR=0
SET PSOTEMP=0
SET XX=0
+3 SET PSOFORGN=$PIECE($GET(VAPA(25)),"^",2)
IF PSOFORGN'=""
IF PSOFORGN'["UNITED STATES"
SET PSOFORGN=1
+4 IF 'PSOFORGN
SET PSOBADR=$$BADADR^DGUTL3(DFN)
+5 IF 'PSOFORGN
IF PSOBADR
SET PSOTEMP=$$CHKTEMP^PSOBAI(DFN)
+6 FOR I=1:1:3
IF $GET(VAPA(I))]""
Begin DoDot:1
+7 SET T=""
IF I=1
IF 'PSOFORGN
IF PSOBADR
IF '$GET(PSOTEMP)
SET T="** BAD ADDRESS INDICATED **"
+8 IF I=1
IF T=""
IF PSOFORGN
SET T="*** FOREIGN ADDRESS ***"
+9 IF T=""
IF 'PSOFORGN
IF 'PSOBADR!$GET(PSOTEMP)
SET T=$GET(VAPA(I))
+10 IF I=1
IF T]""
SET ^TMP(ZZ,$JOB,LC)="Address : "_T
SET LC=LC+1
+11 IF I>1
IF T]""
SET ^TMP(ZZ,$JOB,LC)=" "_T
SET LC=LC+1
End DoDot:1
+12 SET I=+$GET(VAPA(5))
IF I
SET I=$SELECT($DATA(^DIC(5,I,0)):$PIECE(^(0),"^",2),1:"UNKNOWN")
+13 SET T=""
IF 'PSOFORGN
IF 'PSOBADR!$GET(PSOTEMP)
SET T=$GET(VAPA(4))_", "_I_" "_$SELECT($GET(VAPA(11)):$PIECE(VAPA(11),"^",2),1:$GET(VAPA(6)))
+14 if T]""
SET ^TMP(ZZ,$JOB,LC)=" "_T
SET LC=LC+1
+15 QUIT
+16 ;
