PSD68P ;B'ham ISC/RJS - PSD*3*68 POST INSTALL ; 30 Oct 09
;;3.0; CONTROLLED SUBSTANCES ;**68**;30 Oct 09;Build 12
;Identify bad PSD(58.81,"D" INDEXES & TRANSACTIONS THEN CLEAN THEM UP
S ZTDESC="CONTROLLED SUBSTANCES - PSD*3*68 POST INSTALL",ZTIO="",ZTDTH=$H,ZTRTN="START^PSD68P",ZTSAVE="" D ^%ZTLOAD
D BMES^XPDUTL("PSD*3*68 POST INSTALL Task Queued!")
Q
START ; FIND NAOU'S
S PSDLOC=0 F S PSDLOC=$O(^PSD(58.8,PSDLOC)) Q:'PSDLOC D
.I $P(^PSD(58.8,PSDLOC,0),U,2)="N" S PSDLOC(PSDLOC)=1
;
; LOOP THROUGH ^PSD(58.81 & GATHER ALL NAOU TRANSACTIONS WITH RX#
;
S PSDTRN=0 F S PSDTRN=$O(^PSD(58.81,PSDTRN)) Q:'PSDTRN D
.S PSDNAOU=$P(^PSD(58.81,PSDTRN,0),U,18)
.Q:$G(PSDNAOU)=""
.Q:'$G(PSDLOC(PSDNAOU))
.S PSDPN=$P(^PSD(58.81,PSDTRN,0),U,17),PSDRG=$P(^PSD(58.81,PSDTRN,0),U,5)
.I $G(PSDPN) D
..S ^TMP($J,"PSD68P",PSDNAOU,PSDPN,PSDRG,PSDTRN)=^PSD(58.81,PSDTRN,0)
..S ^TMP($J,"PSD68P",PSDNAOU,PSDPN)=$G(^TMP($J,"PSD68P",PSDNAOU,PSDPN))+1
;
; LOOP THROUGH ^TMP($J,"PSD68P AND FIND BAD DRUG DISPENSING # & INDEX
;
S XMSUB="PSD*3*68 POST INSTALL Report",PSDRPT="PSD68P-D"
S ^TMP($J,PSDRPT,1)="PSD*3*68 DRUG ACCOUNTABILITY TRANSACTION Drug Dispensing # Index Repair"
S ^TMP($J,PSDRPT,2)=""
S ^TMP($J,PSDRPT,3)="The following Drug Dispensing # Index for the DRUG ACCOUNTABILITY TRANSACTION"
S ^TMP($J,PSDRPT,4)="file have been fixed."
S ^TMP($J,PSDRPT,5)=""
S PSDTXT="" D TXT("Transaction#",1),TXT("Drug Name",15),TXT("Dispensing#",60)
S ^TMP($J,PSDRPT,6)=PSDTXT,^TMP($J,PSDRPT,7)="",PSDCNT=7
S PSDNAOU="" F S PSDNAOU=$O(^TMP($J,"PSD68P",PSDNAOU)) Q:'PSDNAOU D
.S PSDPN="" F S PSDPN=$O(^TMP($J,"PSD68P",PSDNAOU,PSDPN)) Q:'PSDPN D
..I $G(^TMP($J,"PSD68P",PSDNAOU,PSDPN))=1 K ^TMP($J,"PSD68P",PSDNAOU,PSDPN) Q
..S PSDRG="" F S PSDRG=$O(^TMP($J,"PSD68P",PSDNAOU,PSDPN,PSDRG)) Q:'PSDRG D CLEAN
..K ^TMP($J,"PSD68P",PSDNAOU,PSDPN)
I '$G(PSDFND) S ^TMP($J,PSDRPT,3)="There were NO incorrect Drug Dispensing # Indexes found.",^TMP($J,PSDRPT,4)="",PSDCNT=5
D MAIL
Q
TXT(PSDVAL,PSDCOL) ; FORAMT THE MAILMAN TEXT
S:'$D(PSDTXT) PSDTXT="" S PSDTXT=$$SETSTR^VALM1(PSDVAL,PSDTXT,PSDCOL,$L(PSDVAL))
Q
CLEAN ; REMOVE THE BAD DRUG DISPENSING # & INDEX
S PSDTRN=0 F S PSDTRN=$O(^TMP($J,"PSD68P",PSDNAOU,PSDPN,PSDRG,PSDTRN)) Q:'PSDTRN D
.Q:$P(^TMP($J,"PSD68P",PSDNAOU,PSDPN,PSDRG,PSDTRN),"^",2)'=17
.S PSDDT=$P(^TMP($J,"PSD68P",PSDNAOU,PSDPN,PSDRG,PSDTRN),"^",4),PSDDAYS=$$FMDIFF^DILIBF(DT,PSDDT,"")
.S $P(^PSD(58.81,PSDTRN,0),U,17)="",$P(^PSD(58.81,PSDTRN,0),U,20)="",PSDFND=1
.D MQUE
.K ^PSD(58.81,"D",PSDPN,PSDTRN)
.K DA,DIK S DA=PSDTRN,DIK="^PSD(58.81," D IX^DIK K DA,DIK
Q
MQUE ; STEP UP THE ^TMP( DATA FOR THE MAILMAN MESSAGE
S PSDTXT="" D TXT(PSDTRN,2),TXT($P(^PSDRUG(PSDRG,0),"^"),15),TXT(PSDPN,62)
S PSDCNT=PSDCNT+1,^TMP($J,PSDRPT,PSDCNT)=PSDTXT
S PSDCNT=PSDCNT+1,^TMP($J,PSDRPT,PSDCNT)=""
Q
MAIL ; SEND THE MAILMAN MESSAGE
N DIFROM
S PSDCNT=PSDCNT+1,^TMP($J,PSDRPT,PSDCNT)="***** End Of Report *****"
S XMTEXT="^TMP($J,PSDRPT,",XMDUZ="PSD*3*68 Post Install"
S PSDDUZ=0 F S PSDDUZ=$O(^XUSEC("PSDMGR",PSDDUZ)) Q:'PSDDUZ S XMY(PSDDUZ)=""
D ^XMD
EXIT ; CLEAN UP
K ^TMP($J),XMDUZ,XMSUB,XMTEXT,XMY,PSDCNT,PSDDAYS,PSDDT,PSDDUZ,PSDFND,PSDRPT,PSDRG,PSDPN,PSDTRN,PSDNAOU,PSDLOC,PSDVAL,PSDCOL,PSDTXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSD68P 3305 printed Nov 22, 2024@16:54:54 Page 2
PSD68P ;B'ham ISC/RJS - PSD*3*68 POST INSTALL ; 30 Oct 09
+1 ;;3.0; CONTROLLED SUBSTANCES ;**68**;30 Oct 09;Build 12
+2 ;Identify bad PSD(58.81,"D" INDEXES & TRANSACTIONS THEN CLEAN THEM UP
+3 SET ZTDESC="CONTROLLED SUBSTANCES - PSD*3*68 POST INSTALL"
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTRTN="START^PSD68P"
SET ZTSAVE=""
DO ^%ZTLOAD
+4 DO BMES^XPDUTL("PSD*3*68 POST INSTALL Task Queued!")
+5 QUIT
START ; FIND NAOU'S
+1 SET PSDLOC=0
FOR
SET PSDLOC=$ORDER(^PSD(58.8,PSDLOC))
if 'PSDLOC
QUIT
Begin DoDot:1
+2 IF $PIECE(^PSD(58.8,PSDLOC,0),U,2)="N"
SET PSDLOC(PSDLOC)=1
End DoDot:1
+3 ;
+4 ; LOOP THROUGH ^PSD(58.81 & GATHER ALL NAOU TRANSACTIONS WITH RX#
+5 ;
+6 SET PSDTRN=0
FOR
SET PSDTRN=$ORDER(^PSD(58.81,PSDTRN))
if 'PSDTRN
QUIT
Begin DoDot:1
+7 SET PSDNAOU=$PIECE(^PSD(58.81,PSDTRN,0),U,18)
+8 if $GET(PSDNAOU)=""
QUIT
+9 if '$GET(PSDLOC(PSDNAOU))
QUIT
+10 SET PSDPN=$PIECE(^PSD(58.81,PSDTRN,0),U,17)
SET PSDRG=$PIECE(^PSD(58.81,PSDTRN,0),U,5)
+11 IF $GET(PSDPN)
Begin DoDot:2
+12 SET ^TMP($JOB,"PSD68P",PSDNAOU,PSDPN,PSDRG,PSDTRN)=^PSD(58.81,PSDTRN,0)
+13 SET ^TMP($JOB,"PSD68P",PSDNAOU,PSDPN)=$GET(^TMP($JOB,"PSD68P",PSDNAOU,PSDPN))+1
End DoDot:2
End DoDot:1
+14 ;
+15 ; LOOP THROUGH ^TMP($J,"PSD68P AND FIND BAD DRUG DISPENSING # & INDEX
+16 ;
+17 SET XMSUB="PSD*3*68 POST INSTALL Report"
SET PSDRPT="PSD68P-D"
+18 SET ^TMP($JOB,PSDRPT,1)="PSD*3*68 DRUG ACCOUNTABILITY TRANSACTION Drug Dispensing # Index Repair"
+19 SET ^TMP($JOB,PSDRPT,2)=""
+20 SET ^TMP($JOB,PSDRPT,3)="The following Drug Dispensing # Index for the DRUG ACCOUNTABILITY TRANSACTION"
+21 SET ^TMP($JOB,PSDRPT,4)="file have been fixed."
+22 SET ^TMP($JOB,PSDRPT,5)=""
+23 SET PSDTXT=""
DO TXT("Transaction#",1)
DO TXT("Drug Name",15)
DO TXT("Dispensing#",60)
+24 SET ^TMP($JOB,PSDRPT,6)=PSDTXT
SET ^TMP($JOB,PSDRPT,7)=""
SET PSDCNT=7
+25 SET PSDNAOU=""
FOR
SET PSDNAOU=$ORDER(^TMP($JOB,"PSD68P",PSDNAOU))
if 'PSDNAOU
QUIT
Begin DoDot:1
+26 SET PSDPN=""
FOR
SET PSDPN=$ORDER(^TMP($JOB,"PSD68P",PSDNAOU,PSDPN))
if 'PSDPN
QUIT
Begin DoDot:2
+27 IF $GET(^TMP($JOB,"PSD68P",PSDNAOU,PSDPN))=1
KILL ^TMP($JOB,"PSD68P",PSDNAOU,PSDPN)
QUIT
+28 SET PSDRG=""
FOR
SET PSDRG=$ORDER(^TMP($JOB,"PSD68P",PSDNAOU,PSDPN,PSDRG))
if 'PSDRG
QUIT
DO CLEAN
+29 KILL ^TMP($JOB,"PSD68P",PSDNAOU,PSDPN)
End DoDot:2
End DoDot:1
+30 IF '$GET(PSDFND)
SET ^TMP($JOB,PSDRPT,3)="There were NO incorrect Drug Dispensing # Indexes found."
SET ^TMP($JOB,PSDRPT,4)=""
SET PSDCNT=5
+31 DO MAIL
+32 QUIT
TXT(PSDVAL,PSDCOL) ; FORAMT THE MAILMAN TEXT
+1 if '$DATA(PSDTXT)
SET PSDTXT=""
SET PSDTXT=$$SETSTR^VALM1(PSDVAL,PSDTXT,PSDCOL,$LENGTH(PSDVAL))
+2 QUIT
CLEAN ; REMOVE THE BAD DRUG DISPENSING # & INDEX
+1 SET PSDTRN=0
FOR
SET PSDTRN=$ORDER(^TMP($JOB,"PSD68P",PSDNAOU,PSDPN,PSDRG,PSDTRN))
if 'PSDTRN
QUIT
Begin DoDot:1
+2 if $PIECE(^TMP($JOB,"PSD68P",PSDNAOU,PSDPN,PSDRG,PSDTRN),"^",2)'=17
QUIT
+3 SET PSDDT=$PIECE(^TMP($JOB,"PSD68P",PSDNAOU,PSDPN,PSDRG,PSDTRN),"^",4)
SET PSDDAYS=$$FMDIFF^DILIBF(DT,PSDDT,"")
+4 SET $PIECE(^PSD(58.81,PSDTRN,0),U,17)=""
SET $PIECE(^PSD(58.81,PSDTRN,0),U,20)=""
SET PSDFND=1
+5 DO MQUE
+6 KILL ^PSD(58.81,"D",PSDPN,PSDTRN)
+7 KILL DA,DIK
SET DA=PSDTRN
SET DIK="^PSD(58.81,"
DO IX^DIK
KILL DA,DIK
End DoDot:1
+8 QUIT
MQUE ; STEP UP THE ^TMP( DATA FOR THE MAILMAN MESSAGE
+1 SET PSDTXT=""
DO TXT(PSDTRN,2)
DO TXT($PIECE(^PSDRUG(PSDRG,0),"^"),15)
DO TXT(PSDPN,62)
+2 SET PSDCNT=PSDCNT+1
SET ^TMP($JOB,PSDRPT,PSDCNT)=PSDTXT
+3 SET PSDCNT=PSDCNT+1
SET ^TMP($JOB,PSDRPT,PSDCNT)=""
+4 QUIT
MAIL ; SEND THE MAILMAN MESSAGE
+1 NEW DIFROM
+2 SET PSDCNT=PSDCNT+1
SET ^TMP($JOB,PSDRPT,PSDCNT)="***** End Of Report *****"
+3 SET XMTEXT="^TMP($J,PSDRPT,"
SET XMDUZ="PSD*3*68 Post Install"
+4 SET PSDDUZ=0
FOR
SET PSDDUZ=$ORDER(^XUSEC("PSDMGR",PSDDUZ))
if 'PSDDUZ
QUIT
SET XMY(PSDDUZ)=""
+5 DO ^XMD
EXIT ; CLEAN UP
+1 KILL ^TMP($JOB),XMDUZ,XMSUB,XMTEXT,XMY,PSDCNT,PSDDAYS,PSDDT,PSDDUZ,PSDFND,PSDRPT,PSDRG,PSDPN,PSDTRN,PSDNAOU,PSDLOC,PSDVAL,PSDCOL,PSDTXT
+2 QUIT
