PSO55FX2 ;ISC-BHAM/MHA - cleanup of bad p nodes and mismatched Rxs in file 55 ; 07/26/2001
;;7.0;OUTPATIENT PHARMACY;**69**;DEC 1997
;External reference to ^PS(55 is supported by DBIA 2228
;External reference ^DGPM("AMV1" is supported by DBIA 2249
Q
BEG ;
I '$D(DUZ) W !!!!,"* DUZ NOT DEFINED - QUITTING *" Q
D MSG^PSO55FX3
K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Select the Date/Time to queue this job: "
D ^%DT K %DT
I $D(DTOUT)!(Y<0) W !!!?10,"Job not queued - quitting!" Q
S ZTDTH=$G(Y),ZTSAVE("DUZ")="",ZTIO="",ZTRTN="EN^PSO55FX2",ZTDESC="Cleanup of bad 'P' cross-references in Pharmacy Patient file"
D ^%ZTLOAD W:$D(ZTSK) !!,"Task Queued To Run!",!
Q
EN ;
I $G(^XTMP("PSO2",69))="PH1" D PH2^PSO55FX3 Q
S TY="PSO",JN=69 S (DFN,ZA,ZB,ZC)=0
I '$D(^XTMP(TY,JN)) S X1=DT,X2=+90 D C^%DTC S ^XTMP(TY,JN,0)=$G(X)_"^"_DT G EN1
I $D(^XTMP(TY,JN,1)) D
.S DFN=$P(^XTMP(TY,JN,1),"^") S:'DFN DFN=0
.S ZA=$P(^XTMP(TY,JN,1),"^",2) S:'ZA ZA=0
.S ZB=$P(^XTMP(TY,JN,1),"^",3) S:'ZB ZB=0
.S ZC=$P(^XTMP(TY,JN,1),"^",4) S:'ZC ZC=0
EN1 S STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUE (EDIT)^PROVIDER HOLD"
F S DFN=$O(^PS(55,DFN)) Q:'DFN D CHK1,CHK2 S ^XTMP(TY,JN,1)=DFN_"^"_ZA_"^"_ZB_"^"_ZC
D SMAIL S ^XTMP("PSO2",69)="PH1" D PH2^PSO55FX3
Q
CHK1 ;for every patient go through the "P" x-ref
K XZ S (RB,I)=0 F S I=$O(^PS(55,DFN,"P",I)) Q:'I S RX=$P($G(^(I,0)),"^") D:RX
.;checks for non-existing Rxs or Rxs with no header record & if found clean it up
.I '$D(^PSRX(RX)) S RB=1,ZA=ZA+1,XZ(RX)="" K ^PS(55,DFN,"P",I,0) Q
.I '$D(^PSRX(RX,0)) S RB=1,ZA=ZA+1,XZ(RX)="" K ^PS(55,DFN,"P",I,0) Q
.;checks for patient mis-match
.I DFN'=+$P(^PSRX(RX,0),"^",2) D
..S ZA=ZA+1,RB=1,XZ(RX)="" K ^PS(55,DFN,"P",I,0)
..D:+$P($G(^PSRX(RX,"STA")),"^")=12 ALOG
D:RB RBP
Q
ALOG ;
S CDFN=+$P(^PSRX(RX,0),"^",2)
Q:$P($G(^DPT(CDFN,.35)),"^")
S (II,JJ,CT)=0,AL="ZZZ"
F S II=$O(^PSRX(RX,"A",II)) Q:'II S:$P($G(^(II,0)),"^",5)["Auto Discontinued on Admission" JJ=II
I JJ S CDT=$P($G(^PSRX(RX,"A",JJ,0)),"^") Q:'CDT D
.S X1=$E(CDT,1,7),X2=-3 D C^%DTC S SDT=X-.01,EDT=X_".99999"
.F S SDT=$O(^DGPM("AMV1",SDT)) Q:'SDT!(SDT>EDT)!(CT) D
..S PDFN=0 F S PDFN=$O(^DGPM("AMV1",SDT,PDFN)) Q:'PDFN!(PDFN=CDFN)
..S:+PDFN=CDFN CT=1
Q:CT
S:JJ AL="Auto Discontinued on Admission" S (II,JJ)=0
F S II=$O(^PSRX(RX,"A",II)) Q:'II S:$P($G(^(II,0)),"^",5)["Auto Discontinued Due" JJ=II
S:JJ AL=$P(^PSRX(RX,"A",JJ,0),"^",5)
S DIV=$P($G(^PSRX(RX,2)),"^",9) S:DIV="" DIV=998899
CREC ;
S SSN=$P($G(^DPT(CDFN,0)),"^",9) S:SSN="" SSN="N/A"
S NAME=$P($G(^DPT(CDFN,0)),"^")_" ("_SSN_")" S:NAME="" NAME="N/A"
;S STAT=$P(STA,"^",$P($G(^PSRX(RX,"STA")),"^")+1) S:STAT="" STAT="N/A"
S:'$D(^XTMP(TY,JN,2,DIV,AL,CDFN,RX)) ^XTMP(TY,JN,2,DIV,AL,CDFN,RX)=NAME_"^"_$P(^PSRX(RX,0),"^")_"^"_$S(AL="ZZZ":"",1:AL),ZC=ZC+1
S ^XTMP(TY,JN,"Z",DIV,CDFN,RX)=""
Q
;
CHK2 ;for every patient go through the "P","A" x-ref
S J=0 F S J=$O(^PS(55,DFN,"P","A",J)) Q:'J S RX=0 F S RX=$O(^PS(55,DFN,"P","A",J,RX)) Q:'RX D
.;checks for non-existing Rxs or Rxs with no header record & if found clean it up
.I '$D(^PSRX(RX)) S:'$D(XZ(RX)) ZB=ZB+1 K ^PS(55,DFN,"P","A",J,RX) Q
.I '$D(^PSRX(RX,0)) S:'$D(XZ(RX)) ZB=ZB+1 K ^PS(55,DFN,"P","A",J,RX) Q
.;checks for patient mismatch
.I DFN'=+$P(^PSRX(RX,0),"^",2) D
..S:'$D(XZ(RX)) ZB=ZB+1 K ^PS(55,DFN,"P","A",J,RX)
..D:+$P($G(^PSRX(RX,"STA")),"^")=12 ALOG
K XZ Q
RBP ;rebuild the "P" header rec
S (NR,LR,I)=0 F S I=$O(^PS(55,DFN,"P",I)) Q:'I S LR=I,NR=NR+1
S ^PS(55,DFN,"P",0)="^55.03PA^"_LR_"^"_NR
K NR,LR,RB Q
;
SMAIL ;
S ZZ="PSOFX" K ^TMP(ZZ,$J),XMY
I ZA!(ZB)!(ZC) D
.;S ^TMP(ZZ,$J,1)="**************************************************"
.S ^TMP(ZZ,$J,2)="*** Following cleanup has been done: ***"
.S ^TMP(ZZ,$J,3)="*** ***"
.S ^TMP(ZZ,$J,4)="*** bad P-XREF COUNT "_$E(ZA_" ",1,6)_" ***"
.S ^TMP(ZZ,$J,5)="*** bad PA-XREF COUNT "_$E(ZB_" ",1,6)_" ***"
.S ^TMP(ZZ,$J,6)="*** mismatched PATIENT COUNT "_$E(ZC_" ",1,6)_" ***"
.S ^TMP(ZZ,$J,7)="*** ***"
.I ZC D
..S ^TMP(ZZ,$J,8)="*** The count of mismatched patients may ***"
..S ^TMP(ZZ,$J,9)="*** include multiple counts for the same ***"
..S ^TMP(ZZ,$J,10)="*** patient since bad nodes from more than ***"
..S ^TMP(ZZ,$J,11)="*** one patient could point to different ***"
..S ^TMP(ZZ,$J,12)="*** prescriptions for the same 'good' ***"
..S ^TMP(ZZ,$J,13)="*** patient entry in the PRESCRIPTION ***"
..S ^TMP(ZZ,$J,14)="*** file (#52). ***"
.;S ^TMP(ZZ,$J,15)="**************************************************"
.S ^TMP(ZZ,$J,16)=""
.I ZC D
..S ^TMP(ZZ,$J,17)="A separate message has been sent for the following"
..S ^TMP(ZZ,$J,18)="divisions. Each has one or more mismatched patients"
..S ^TMP(ZZ,$J,19)="that must be reviewed for inaccurate data."
..S ^TMP(ZZ,$J,20)="",XX=21
..K XY S J=0 F S J=$O(^XTMP(TY,JN,"Z",J)) Q:'J D
...S DIV=$P($G(^PS(59,J,0)),"^")
...S (I,L)=0 F S I=$O(^XTMP(TY,JN,"Z",J,I)) Q:'I S L=L+1
...S ^TMP(ZZ,$J,XX)=" "_DIV_": "_L,XX=XX+1,XY(J)=L
E D
.;S ^TMP(ZZ,$J,1)="**************************************************"
.S ^TMP(ZZ,$J,2)="*** No prescriptions were found with possible ***"
.S ^TMP(ZZ,$J,3)="*** bad 'P' or 'P','A' x-refs or prescriptions ***"
.S ^TMP(ZZ,$J,4)="*** associated with the wrong patient. ***"
.;S ^TMP(ZZ,$J,5)="**************************************************"
S XMY(DUZ)="",XMY("G.PL2 PATCH TRACKING@DOMAIN.EXT")=""
S XMSUB="PSO*7*69 - "_$P($$SITE^VASITE(),"^",2)
S XMDUZ="Outpatient Pharmacy Patch 69"
S XMTEXT="^TMP(ZZ,$J," D ^XMD K XMY,^TMP(ZZ,$J)
I $D(^XTMP(TY,JN,2)) S J=0 F S J=$O(^XTMP(TY,JN,2,J)) Q:'J D
.S DIV=$P($G(^PS(59,J,0)),"^")
.S ^TMP(ZZ,$J,J,1)="This message is comprised of two sections. Section 1 lists prescriptions that"
.S ^TMP(ZZ,$J,J,2)="may have been automatically discontinued by mistake, either by a Date of Death"
.S ^TMP(ZZ,$J,J,3)="entry or by the Autocancel on Admission action for a different patient. The"
.S ^TMP(ZZ,$J,J,4)="second section lists other discontinued prescriptions."
.S ^TMP(ZZ,$J,J,5)=""
.S ^TMP(ZZ,$J,J,6)="Please review the following DISCONTINUED prescriptions for the "
.S ^TMP(ZZ,$J,J,8)=DIV_" (division name) Outpatient Site."
.S ^TMP(ZZ,$J,J,9)=""
.S ^TMP(ZZ,$J,J,10)="TOTAL COUNT OF UNIQUE PATIENT IS "_$G(XY(J))
.S ^TMP(ZZ,$J,J,11)=""
.S YY=0,$E(S1,36)="",$E(S2,12)="",K="",$P(UL,"=",66)=""
.S ^TMP(ZZ,$J,J,12)=UL,^TMP(ZZ,$J,J,13)="SECTION 1",^TMP(ZZ,$J,J,14)=""
.S XX=15 F S K=$O(^XTMP(TY,JN,2,J,K)) Q:K="" D
..D:'YY
...S ^TMP(ZZ,$J,J,XX)="Following prescriptions may have been automatically discontinued by mistake,",XX=XX+1
...S ^TMP(ZZ,$J,J,XX)="either by a Date of Death entry or by the Autocancel on Admission action for",XX=XX+1
...S ^TMP(ZZ,$J,J,XX)="a different patient.",XX=XX+1
...S ^TMP(ZZ,$J,J,XX)="",XX=XX+1
...S ^TMP(ZZ,$J,J,XX)=$E("NAME (SSN#)"_S1,1,35)_$E("Rx #"_S2,1,12)_$S(K="ZZZ":"",1:"Discontinued Reason"),XX=XX+1
...S ^TMP(ZZ,$J,J,XX)="",XX=XX+1 S:K["Auto Discontinued" YY=1
..D:K="ZZZ"
...I YY S ^TMP(ZZ,$J,J,XX)="",XX=XX+1,YY=0
...E S ^TMP(ZZ,$J,J,XX)="There were no entries that were automatically discontinued.",XX=XX+1,^TMP(ZZ,$J,J,XX)="",XX=XX+1
...S ^TMP(ZZ,$J,J,XX)=UL,XX=XX+1
...S ^TMP(ZZ,$J,J,XX)="SECTION 2",XX=XX+1,^TMP(ZZ,$J,J,XX)="",XX=XX+1
...S ^TMP(ZZ,$J,J,XX)="The following prescriptions may have been discontinued manually:",XX=XX+1,^TMP(ZZ,$J,J,XX)="",XX=XX+1
..S L=0 F S L=$O(^XTMP(TY,JN,2,J,K,L)) Q:'L D
...S ^TMP(ZZ,$J,J,XX)=""
...S II=0 F S II=$O(^XTMP(TY,JN,2,J,K,L,II)) Q:'II D
....S QQ=^XTMP(TY,JN,2,J,K,L,II)
....I $D(^TMP(ZZ,$J,J,XX)) S ^TMP(ZZ,$J,J,XX)=$E($P(QQ,"^")_S1,1,35)_$E($P(QQ,"^",2)_S2,1,12)_$S(K="ZZZ":"",1:$E($P(QQ,"^",3),1,32)),XX=XX+1
....E S ^TMP(ZZ,$J,J,XX)=S1_$E($P(QQ,"^",2)_S2,1,12)_$S(K="ZZZ":"",1:$E($P(QQ,"^",3),1,32)),XX=XX+1
.D:'$D(^XTMP(TY,JN,2,J,"ZZZ"))
..S ^TMP(ZZ,$J,J,XX)="",XX=XX+1,^TMP(ZZ,$J,J,XX)=UL,XX=XX+1
..S ^TMP(ZZ,$J,J,XX)="SECTION 2",XX=XX+1,^TMP(ZZ,$J,J,XX)="",XX=XX+1
..S ^TMP(ZZ,$J,J,XX)="There were no entries that were manually discontinued.",XX=XX+1,^TMP(ZZ,$J,J,XX)=""
.S XMY(DUZ)="",XMDUZ="Search for possible invalid Prescription status"
.S XMSUB="IMPORTANT - "_$G(DIV)_": Prescriptions to be reviewed."
.S XMTEXT="^TMP(ZZ,$J,J," D ^XMD K XMY,^TMP(ZZ,$J,J)
END K ^XTMP(TY,JN),^TMP(ZZ,$J),XMY,XMDUZ,ZA,ZB,ZC,DFN,CDFN,RX,RB,XY,XX,TY,JN,ZZ,I,J,K,L,NAME,DIV,STA,STAT,X1,X2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSO55FX2 8846 printed Sep 23, 2025@19:59:23 Page 2
PSO55FX2 ;ISC-BHAM/MHA - cleanup of bad p nodes and mismatched Rxs in file 55 ; 07/26/2001
+1 ;;7.0;OUTPATIENT PHARMACY;**69**;DEC 1997
+2 ;External reference to ^PS(55 is supported by DBIA 2228
+3 ;External reference ^DGPM("AMV1" is supported by DBIA 2249
+4 QUIT
BEG ;
+1 IF '$DATA(DUZ)
WRITE !!!!,"* DUZ NOT DEFINED - QUITTING *"
QUIT
+2 DO MSG^PSO55FX3
+3 KILL %DT
DO NOW^%DTC
SET %DT="RAEX"
SET %DT(0)=%
SET %DT("A")="Select the Date/Time to queue this job: "
+4 DO ^%DT
KILL %DT
+5 IF $DATA(DTOUT)!(Y<0)
WRITE !!!?10,"Job not queued - quitting!"
QUIT
+6 SET ZTDTH=$GET(Y)
SET ZTSAVE("DUZ")=""
SET ZTIO=""
SET ZTRTN="EN^PSO55FX2"
SET ZTDESC="Cleanup of bad 'P' cross-references in Pharmacy Patient file"
+7 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Task Queued To Run!",!
+8 QUIT
EN ;
+1 IF $GET(^XTMP("PSO2",69))="PH1"
DO PH2^PSO55FX3
QUIT
+2 SET TY="PSO"
SET JN=69
SET (DFN,ZA,ZB,ZC)=0
+3 IF '$DATA(^XTMP(TY,JN))
SET X1=DT
SET X2=+90
DO C^%DTC
SET ^XTMP(TY,JN,0)=$GET(X)_"^"_DT
GOTO EN1
+4 IF $DATA(^XTMP(TY,JN,1))
Begin DoDot:1
+5 SET DFN=$PIECE(^XTMP(TY,JN,1),"^")
if 'DFN
SET DFN=0
+6 SET ZA=$PIECE(^XTMP(TY,JN,1),"^",2)
if 'ZA
SET ZA=0
+7 SET ZB=$PIECE(^XTMP(TY,JN,1),"^",3)
if 'ZB
SET ZB=0
+8 SET ZC=$PIECE(^XTMP(TY,JN,1),"^",4)
if 'ZC
SET ZC=0
End DoDot:1
EN1 SET STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^DONE^EXPIRED^DISCONTINUED^DELETED^DISCONTINUED^DISCONTINUE (EDIT)^PROVIDER HOLD"
+1 FOR
SET DFN=$ORDER(^PS(55,DFN))
if 'DFN
QUIT
DO CHK1
DO CHK2
SET ^XTMP(TY,JN,1)=DFN_"^"_ZA_"^"_ZB_"^"_ZC
+2 DO SMAIL
SET ^XTMP("PSO2",69)="PH1"
DO PH2^PSO55FX3
+3 QUIT
CHK1 ;for every patient go through the "P" x-ref
+1 KILL XZ
SET (RB,I)=0
FOR
SET I=$ORDER(^PS(55,DFN,"P",I))
if 'I
QUIT
SET RX=$PIECE($GET(^(I,0)),"^")
if RX
Begin DoDot:1
+2 ;checks for non-existing Rxs or Rxs with no header record & if found clean it up
+3 IF '$DATA(^PSRX(RX))
SET RB=1
SET ZA=ZA+1
SET XZ(RX)=""
KILL ^PS(55,DFN,"P",I,0)
QUIT
+4 IF '$DATA(^PSRX(RX,0))
SET RB=1
SET ZA=ZA+1
SET XZ(RX)=""
KILL ^PS(55,DFN,"P",I,0)
QUIT
+5 ;checks for patient mis-match
+6 IF DFN'=+$PIECE(^PSRX(RX,0),"^",2)
Begin DoDot:2
+7 SET ZA=ZA+1
SET RB=1
SET XZ(RX)=""
KILL ^PS(55,DFN,"P",I,0)
+8 if +$PIECE($GET(^PSRX(RX,"STA")),"^")=12
DO ALOG
End DoDot:2
End DoDot:1
+9 if RB
DO RBP
+10 QUIT
ALOG ;
+1 SET CDFN=+$PIECE(^PSRX(RX,0),"^",2)
+2 if $PIECE($GET(^DPT(CDFN,.35)),"^")
QUIT
+3 SET (II,JJ,CT)=0
SET AL="ZZZ"
+4 FOR
SET II=$ORDER(^PSRX(RX,"A",II))
if 'II
QUIT
if $PIECE($GET(^(II,0)),"^",5)["Auto Discontinued on Admission"
SET JJ=II
+5 IF JJ
SET CDT=$PIECE($GET(^PSRX(RX,"A",JJ,0)),"^")
if 'CDT
QUIT
Begin DoDot:1
+6 SET X1=$EXTRACT(CDT,1,7)
SET X2=-3
DO C^%DTC
SET SDT=X-.01
SET EDT=X_".99999"
+7 FOR
SET SDT=$ORDER(^DGPM("AMV1",SDT))
if 'SDT!(SDT>EDT)!(CT)
QUIT
Begin DoDot:2
+8 SET PDFN=0
FOR
SET PDFN=$ORDER(^DGPM("AMV1",SDT,PDFN))
if 'PDFN!(PDFN=CDFN)
QUIT
+9 if +PDFN=CDFN
SET CT=1
End DoDot:2
End DoDot:1
+10 if CT
QUIT
+11 if JJ
SET AL="Auto Discontinued on Admission"
SET (II,JJ)=0
+12 FOR
SET II=$ORDER(^PSRX(RX,"A",II))
if 'II
QUIT
if $PIECE($GET(^(II,0)),"^",5)["Auto Discontinued Due"
SET JJ=II
+13 if JJ
SET AL=$PIECE(^PSRX(RX,"A",JJ,0),"^",5)
+14 SET DIV=$PIECE($GET(^PSRX(RX,2)),"^",9)
if DIV=""
SET DIV=998899
CREC ;
+1 SET SSN=$PIECE($GET(^DPT(CDFN,0)),"^",9)
if SSN=""
SET SSN="N/A"
+2 SET NAME=$PIECE($GET(^DPT(CDFN,0)),"^")_" ("_SSN_")"
if NAME=""
SET NAME="N/A"
+3 ;S STAT=$P(STA,"^",$P($G(^PSRX(RX,"STA")),"^")+1) S:STAT="" STAT="N/A"
+4 if '$DATA(^XTMP(TY,JN,2,DIV,AL,CDFN,RX))
SET ^XTMP(TY,JN,2,DIV,AL,CDFN,RX)=NAME_"^"_$PIECE(^PSRX(RX,0),"^")_"^"_$SELECT(AL="ZZZ":"",1:AL)
SET ZC=ZC+1
+5 SET ^XTMP(TY,JN,"Z",DIV,CDFN,RX)=""
+6 QUIT
+7 ;
CHK2 ;for every patient go through the "P","A" x-ref
+1 SET J=0
FOR
SET J=$ORDER(^PS(55,DFN,"P","A",J))
if 'J
QUIT
SET RX=0
FOR
SET RX=$ORDER(^PS(55,DFN,"P","A",J,RX))
if 'RX
QUIT
Begin DoDot:1
+2 ;checks for non-existing Rxs or Rxs with no header record & if found clean it up
+3 IF '$DATA(^PSRX(RX))
if '$DATA(XZ(RX))
SET ZB=ZB+1
KILL ^PS(55,DFN,"P","A",J,RX)
QUIT
+4 IF '$DATA(^PSRX(RX,0))
if '$DATA(XZ(RX))
SET ZB=ZB+1
KILL ^PS(55,DFN,"P","A",J,RX)
QUIT
+5 ;checks for patient mismatch
+6 IF DFN'=+$PIECE(^PSRX(RX,0),"^",2)
Begin DoDot:2
+7 if '$DATA(XZ(RX))
SET ZB=ZB+1
KILL ^PS(55,DFN,"P","A",J,RX)
+8 if +$PIECE($GET(^PSRX(RX,"STA")),"^")=12
DO ALOG
End DoDot:2
End DoDot:1
+9 KILL XZ
QUIT
RBP ;rebuild the "P" header rec
+1 SET (NR,LR,I)=0
FOR
SET I=$ORDER(^PS(55,DFN,"P",I))
if 'I
QUIT
SET LR=I
SET NR=NR+1
+2 SET ^PS(55,DFN,"P",0)="^55.03PA^"_LR_"^"_NR
+3 KILL NR,LR,RB
QUIT
+4 ;
SMAIL ;
+1 SET ZZ="PSOFX"
KILL ^TMP(ZZ,$JOB),XMY
+2 IF ZA!(ZB)!(ZC)
Begin DoDot:1
+3 ;S ^TMP(ZZ,$J,1)="**************************************************"
+4 SET ^TMP(ZZ,$JOB,2)="*** Following cleanup has been done: ***"
+5 SET ^TMP(ZZ,$JOB,3)="*** ***"
+6 SET ^TMP(ZZ,$JOB,4)="*** bad P-XREF COUNT "_$EXTRACT(ZA_" ",1,6)_" ***"
+7 SET ^TMP(ZZ,$JOB,5)="*** bad PA-XREF COUNT "_$EXTRACT(ZB_" ",1,6)_" ***"
+8 SET ^TMP(ZZ,$JOB,6)="*** mismatched PATIENT COUNT "_$EXTRACT(ZC_" ",1,6)_" ***"
+9 SET ^TMP(ZZ,$JOB,7)="*** ***"
+10 IF ZC
Begin DoDot:2
+11 SET ^TMP(ZZ,$JOB,8)="*** The count of mismatched patients may ***"
+12 SET ^TMP(ZZ,$JOB,9)="*** include multiple counts for the same ***"
+13 SET ^TMP(ZZ,$JOB,10)="*** patient since bad nodes from more than ***"
+14 SET ^TMP(ZZ,$JOB,11)="*** one patient could point to different ***"
+15 SET ^TMP(ZZ,$JOB,12)="*** prescriptions for the same 'good' ***"
+16 SET ^TMP(ZZ,$JOB,13)="*** patient entry in the PRESCRIPTION ***"
+17 SET ^TMP(ZZ,$JOB,14)="*** file (#52). ***"
End DoDot:2
+18 ;S ^TMP(ZZ,$J,15)="**************************************************"
+19 SET ^TMP(ZZ,$JOB,16)=""
+20 IF ZC
Begin DoDot:2
+21 SET ^TMP(ZZ,$JOB,17)="A separate message has been sent for the following"
+22 SET ^TMP(ZZ,$JOB,18)="divisions. Each has one or more mismatched patients"
+23 SET ^TMP(ZZ,$JOB,19)="that must be reviewed for inaccurate data."
+24 SET ^TMP(ZZ,$JOB,20)=""
SET XX=21
+25 KILL XY
SET J=0
FOR
SET J=$ORDER(^XTMP(TY,JN,"Z",J))
if 'J
QUIT
Begin DoDot:3
+26 SET DIV=$PIECE($GET(^PS(59,J,0)),"^")
+27 SET (I,L)=0
FOR
SET I=$ORDER(^XTMP(TY,JN,"Z",J,I))
if 'I
QUIT
SET L=L+1
+28 SET ^TMP(ZZ,$JOB,XX)=" "_DIV_": "_L
SET XX=XX+1
SET XY(J)=L
End DoDot:3
End DoDot:2
End DoDot:1
+29 IF '$TEST
Begin DoDot:1
+30 ;S ^TMP(ZZ,$J,1)="**************************************************"
+31 SET ^TMP(ZZ,$JOB,2)="*** No prescriptions were found with possible ***"
+32 SET ^TMP(ZZ,$JOB,3)="*** bad 'P' or 'P','A' x-refs or prescriptions ***"
+33 SET ^TMP(ZZ,$JOB,4)="*** associated with the wrong patient. ***"
+34 ;S ^TMP(ZZ,$J,5)="**************************************************"
End DoDot:1
+35 SET XMY(DUZ)=""
SET XMY("G.PL2 PATCH TRACKING@DOMAIN.EXT")=""
+36 SET XMSUB="PSO*7*69 - "_$PIECE($$SITE^VASITE(),"^",2)
+37 SET XMDUZ="Outpatient Pharmacy Patch 69"
+38 SET XMTEXT="^TMP(ZZ,$J,"
DO ^XMD
KILL XMY,^TMP(ZZ,$JOB)
+39 IF $DATA(^XTMP(TY,JN,2))
SET J=0
FOR
SET J=$ORDER(^XTMP(TY,JN,2,J))
if 'J
QUIT
Begin DoDot:1
+40 SET DIV=$PIECE($GET(^PS(59,J,0)),"^")
+41 SET ^TMP(ZZ,$JOB,J,1)="This message is comprised of two sections. Section 1 lists prescriptions that"
+42 SET ^TMP(ZZ,$JOB,J,2)="may have been automatically discontinued by mistake, either by a Date of Death"
+43 SET ^TMP(ZZ,$JOB,J,3)="entry or by the Autocancel on Admission action for a different patient. The"
+44 SET ^TMP(ZZ,$JOB,J,4)="second section lists other discontinued prescriptions."
+45 SET ^TMP(ZZ,$JOB,J,5)=""
+46 SET ^TMP(ZZ,$JOB,J,6)="Please review the following DISCONTINUED prescriptions for the "
+47 SET ^TMP(ZZ,$JOB,J,8)=DIV_" (division name) Outpatient Site."
+48 SET ^TMP(ZZ,$JOB,J,9)=""
+49 SET ^TMP(ZZ,$JOB,J,10)="TOTAL COUNT OF UNIQUE PATIENT IS "_$GET(XY(J))
+50 SET ^TMP(ZZ,$JOB,J,11)=""
+51 SET YY=0
SET $EXTRACT(S1,36)=""
SET $EXTRACT(S2,12)=""
SET K=""
SET $PIECE(UL,"=",66)=""
+52 SET ^TMP(ZZ,$JOB,J,12)=UL
SET ^TMP(ZZ,$JOB,J,13)="SECTION 1"
SET ^TMP(ZZ,$JOB,J,14)=""
+53 SET XX=15
FOR
SET K=$ORDER(^XTMP(TY,JN,2,J,K))
if K=""
QUIT
Begin DoDot:2
+54 if 'YY
Begin DoDot:3
+55 SET ^TMP(ZZ,$JOB,J,XX)="Following prescriptions may have been automatically discontinued by mistake,"
SET XX=XX+1
+56 SET ^TMP(ZZ,$JOB,J,XX)="either by a Date of Death entry or by the Autocancel on Admission action for"
SET XX=XX+1
+57 SET ^TMP(ZZ,$JOB,J,XX)="a different patient."
SET XX=XX+1
+58 SET ^TMP(ZZ,$JOB,J,XX)=""
SET XX=XX+1
+59 SET ^TMP(ZZ,$JOB,J,XX)=$EXTRACT("NAME (SSN#)"_S1,1,35)_$EXTRACT("Rx #"_S2,1,12)_$SELECT(K="ZZZ":"",1:"Discontinued Reason")
SET XX=XX+1
+60 SET ^TMP(ZZ,$JOB,J,XX)=""
SET XX=XX+1
if K["Auto Discontinued"
SET YY=1
End DoDot:3
+61 if K="ZZZ"
Begin DoDot:3
+62 IF YY
SET ^TMP(ZZ,$JOB,J,XX)=""
SET XX=XX+1
SET YY=0
+63 IF '$TEST
SET ^TMP(ZZ,$JOB,J,XX)="There were no entries that were automatically discontinued."
SET XX=XX+1
SET ^TMP(ZZ,$JOB,J,XX)=""
SET XX=XX+1
+64 SET ^TMP(ZZ,$JOB,J,XX)=UL
SET XX=XX+1
+65 SET ^TMP(ZZ,$JOB,J,XX)="SECTION 2"
SET XX=XX+1
SET ^TMP(ZZ,$JOB,J,XX)=""
SET XX=XX+1
+66 SET ^TMP(ZZ,$JOB,J,XX)="The following prescriptions may have been discontinued manually:"
SET XX=XX+1
SET ^TMP(ZZ,$JOB,J,XX)=""
SET XX=XX+1
End DoDot:3
+67 SET L=0
FOR
SET L=$ORDER(^XTMP(TY,JN,2,J,K,L))
if 'L
QUIT
Begin DoDot:3
+68 SET ^TMP(ZZ,$JOB,J,XX)=""
+69 SET II=0
FOR
SET II=$ORDER(^XTMP(TY,JN,2,J,K,L,II))
if 'II
QUIT
Begin DoDot:4
+70 SET QQ=^XTMP(TY,JN,2,J,K,L,II)
+71 IF $DATA(^TMP(ZZ,$JOB,J,XX))
SET ^TMP(ZZ,$JOB,J,XX)=$EXTRACT($PIECE(QQ,"^")_S1,1,35)_$EXTRACT($PIECE(QQ,"^",2)_S2,1,12)_$SELECT(K="ZZZ":"",1:$EXTRACT($PIECE(QQ,"^",3),1,32))
SET XX=XX+1
+72 IF '$TEST
SET ^TMP(ZZ,$JOB,J,XX)=S1_$EXTRACT($PIECE(QQ,"^",2)_S2,1,12)_$SELECT(K="ZZZ":"",1:$EXTRACT($PIECE(QQ,"^",3),1,32))
SET XX=XX+1
End DoDot:4
End DoDot:3
End DoDot:2
+73 if '$DATA(^XTMP(TY,JN,2,J,"ZZZ"))
Begin DoDot:2
+74 SET ^TMP(ZZ,$JOB,J,XX)=""
SET XX=XX+1
SET ^TMP(ZZ,$JOB,J,XX)=UL
SET XX=XX+1
+75 SET ^TMP(ZZ,$JOB,J,XX)="SECTION 2"
SET XX=XX+1
SET ^TMP(ZZ,$JOB,J,XX)=""
SET XX=XX+1
+76 SET ^TMP(ZZ,$JOB,J,XX)="There were no entries that were manually discontinued."
SET XX=XX+1
SET ^TMP(ZZ,$JOB,J,XX)=""
End DoDot:2
+77 SET XMY(DUZ)=""
SET XMDUZ="Search for possible invalid Prescription status"
+78 SET XMSUB="IMPORTANT - "_$GET(DIV)_": Prescriptions to be reviewed."
+79 SET XMTEXT="^TMP(ZZ,$J,J,"
DO ^XMD
KILL XMY,^TMP(ZZ,$JOB,J)
End DoDot:1
END KILL ^XTMP(TY,JN),^TMP(ZZ,$JOB),XMY,XMDUZ,ZA,ZB,ZC,DFN,CDFN,RX,RB,XY,XX,TY,JN,ZZ,I,J,K,L,NAME,DIV,STA,STAT,X1,X2
+1 QUIT
