PSD79P ;DAL/RJS - PSD*3*79 DATA FIX ;8/15/12
;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**79**;10/24/97;Build 20
Q
EN ; POST INSTALL ENTRY POINT
;Identify and fix multiple Pharmacy Dispensing numbers assigned to a single request number in the Narcotics
;Area Of Use (NAOU) during order processing.
S ZTDESC="CONTROLLED SUBSTANCES - PSD*3*79 POST INSTALL",ZTIO="",ZTDTH=$H,ZTRTN="START^PSD79P",ZTSAVE="" D ^%ZTLOAD
D BMES^XPDUTL("PSD*3*79 POST INSTALL Task Queued!")
K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
Q
START ;
K ^TMP($J,"PSD79P")
N PSDPN,PSDTR,PSD81,PSDREQ,PSDNAOU,PSDRG,PSD8
; Gathering All entries in 58.81 (PSDPN: Pharmacy Dispensing #, PSDTR: Transaction IEN, PSDNAOU: NAOU, PSDREQ: Order Request #, PSDRG: Drug IEN)
S PSDPN="" F S PSDPN=$O(^PSD(58.81,"D",PSDPN)) Q:PSDPN="" D
.S PSDTR=0 F S PSDTR=$O(^PSD(58.81,"D",PSDPN,PSDTR)) Q:'PSDTR D
..S PSD81(0)=$G(^PSD(58.81,PSDTR,0)),PSDREQ=$P(PSD81(0),"^",20),PSDNAOU=$P(PSD81(0),"^",18),PSDRG=$P(PSD81(0),"^",5)
..I $G(PSDNAOU),$G(PSDRG),$G(PSDREQ) D
...S ^TMP($J,"PSD79P",PSDNAOU,PSDRG,PSDREQ,PSDTR)=""
...S ^TMP($J,"PSD79P",PSDNAOU,PSDRG,PSDREQ)=$G(^TMP($J,"PSD79P",PSDNAOU,PSDRG,PSDREQ))+1
;
K ^TMP($J,"PSD79P1")
; Identifying entries with issue (missing 58.8 sub-file correspong record)
S PSDNAOU=0 F S PSDNAOU=$O(^TMP($J,"PSD79P",PSDNAOU)) Q:'PSDNAOU D
.S PSDRG=0 F S PSDRG=$O(^TMP($J,"PSD79P",PSDNAOU,PSDRG)) Q:'PSDRG D
..S PSDREQ=0 F S PSDREQ=$O(^TMP($J,"PSD79P",PSDNAOU,PSDRG,PSDREQ)) Q:'PSDREQ D
...I $G(^TMP($J,"PSD79P",PSDNAOU,PSDRG,PSDREQ))>1 D
....S PSDTR=0 F S PSDTR=$O(^TMP($J,"PSD79P",PSDNAOU,PSDRG,PSDREQ,PSDTR)) Q:'PSDTR D
.....S PSD8(0)=$G(^PSD(58.8,PSDNAOU,1,PSDRG,3,PSDREQ,0)) I $P(PSD8(0),"^",17)="" Q
.....I PSDTR'=$P(PSD8(0),"^",17) S ^TMP($J,"PSD79P1",PSDNAOU,PSDRG,PSDTR)=PSDREQ_"^"_$P(PSD8(0),"^",17)
;
K ^TMP($J,"PSD79P2")
; Fixing entries with issue (missing 58.8 sub-file correspong record)
S PSDNAOU=0 F S PSDNAOU=$O(^TMP($J,"PSD79P1",PSDNAOU)) Q:'PSDNAOU D
.S PSDRG=0 F S PSDRG=$O(^TMP($J,"PSD79P1",PSDNAOU,PSDRG)) Q:'PSDRG D
..S PSDTR=0 F S PSDTR=$O(^TMP($J,"PSD79P1",PSDNAOU,PSDRG,PSDTR)) Q:'PSDTR D
...S PSDREQ=$P($G(^TMP($J,"PSD79P1",PSDNAOU,PSDRG,PSDTR)),"^",1),PSDTRN=$P($G(^TMP($J,"PSD79P1",PSDNAOU,PSDRG,PSDTR)),"^",2)
...S PSD81(0)=$G(^PSD(58.81,PSDTR,0)),PSDPN=$P(PSD81(0),"^",17),PSD81(1)=$G(^PSD(58.81,PSDTR,1))
...S PSD8(0)=$G(^PSD(58.8,PSDNAOU,1,PSDRG,3,PSDREQ,0)),PSDRQ=$P($G(^PSD(58.8,PSDNAOU,1,PSDRG,3,0)),"^",3)
...S PSDS=$P(PSD81(0),"^",3),PSDQTY=$P(PSD81(0),"^",6),PSDSTAT=$P(PSD81(0),"^",11),PSDMFR=$P(PSD81(0),"^",13)
...S PSDDDT=$P(PSD81(0),"^",4)
...S PSDLOT=$P(PSD81(0),"^",14),PSDXDT=$P(PSD81(0),"^",15),PSDCSTAT=$P(PSD81(0),"^",12),PSDCDT=$P(PSD81(0),"^",19)
...S PSDDBY=$P(PSD81(1),"^",1),PSDRBY=$P(PSD81(1),"^",3),PSDT=$P(PSD81(1),"^",6),PSDUZ=$P(PSD81(1),"^",7)
...S PSDRDT=$P(PSD81(1),"^",4),PSDRQTY=$P(PSD81(1),"^",8)
...D DIE
;
; Generating Mailman message with entries cleaned up or No transactions to report message
K D,D0,DI,DIC,DQ,PSD8,PSD81,PSDA,PSDCDT,PSDCNT,PSDCSTAT,PSDDBY,PSDDDT,PSDLOT,PSDMFR,PSDNAOU,PSDPN
K PSDQTY,PSDRBY,PSDRDT,PSDREQ,PSDRQ,PSDRQTY,PSDS,PSDSTAT,PSDT,PSDTR,PSDTRN,PSDUZ,PSDXDT,X
I '$D(^TMP($J,"PSD79P1")) D NOMAIL,MAIL Q
S PSDCNTR=1,PSDROU="PSD79PR",PSDLN="",$P(PSDLN,"=",80)=""
K PSD1,PSD2 F PSD3=1:1 S PSD1=$T(HDR+PSD3) Q:PSD1[";;END" S PSD2=$P(PSD1,";;",2),PSD2(PSD3,0)=PSD1,^TMP($J,PSDROU,PSDCNTR)=PSD2,PSDCNTR=PSDCNTR+1
S ^TMP($J,PSDROU,PSDCNTR)="",PSDCNTR=PSDCNTR+1
S PSDDAT="" D TXT("NAOU",0),TXT("Pharmacy",44),TXT("Transaction",55),TXT("Old",70),TXT("/",73),TXT("New",74)
S ^TMP($J,PSDROU,PSDCNTR)=PSDDAT,PSDCNTR=PSDCNTR+1
S PSDDAT="" D TXT("Drug Name",2),TXT("Dispensing #",43),TXT("Number",58),TXT("Request #",69)
S ^TMP($J,PSDROU,PSDCNTR)=PSDDAT,PSDCNTR=PSDCNTR+1
S ^TMP($J,PSDROU,PSDCNTR)=PSDLN,PSDCNTR=PSDCNTR+1
S PSDNAOU=0 F S PSDNAOU=$O(^TMP($J,"PSD79P2",PSDNAOU)) Q:'PSDNAOU D
.S PSDNAOUN=$P(^PSD(58.8,PSDNAOU,0),"^",1),^TMP($J,PSDROU,PSDCNTR)=PSDNAOUN,PSDCNTR=PSDCNTR+1
.S PSDDRG=0 F S PSDRG=$O(^TMP($J,"PSD79P2",PSDNAOU,PSDRG)) Q:'PSDRG D
..S PSDFLG=0,PSDRGN=$P(^PSDRUG(PSDRG,0),"^",1) I $L(PSDRGN)>40 S PSDRGN=$E(PSDRGN,1,45)
..S PSDTR=0 F S PSDTR=$O(^TMP($J,"PSD79P2",PSDNAOU,PSDRG,PSDTR)) Q:'PSDTR D
...S:'PSDFLG PSDDAT="" D TXT(PSDRGN,2)
...S PSD0=$G(^TMP($J,"PSD79P2",PSDNAOU,PSDRG,PSDTR))
...S PSDPN1=$P(PSD0,"^",2),PSDRQ1=$P(PSD0,"^",1),PSDRQ2=$P(PSD0,"^",3)
...S PSDPN2=$P(PSD0,"^",5),PSDTR2=$P(PSD0,"^",4)
...S:PSDFLG PSDDAT="" D TXT(PSDPN1,45),TXT(PSDTR,57),TXT(PSDRQ2,(73-$L(PSDRQ2))),TXT("/",73),TXT(PSDRQ1,74)
...S ^TMP($J,PSDROU,PSDCNTR)=PSDDAT,PSDCNTR=PSDCNTR+1,PSDFLG=1
...S PSDDAT="" D TXT(PSDPN2,45),TXT(PSDTR2,57),TXT(PSDRQ2,(73-$L(PSDRQ2))),TXT("/",73),TXT("NA",74)
...S ^TMP($J,PSDROU,PSDCNTR)=PSDDAT,PSDCNTR=PSDCNTR+1
...S ^TMP($J,PSDROU,PSDCNTR)="",PSDCNTR=PSDCNTR+1 K PSDATA
D MAIL
;
EXIT ;
K PSD0,PSD3,PSDCNTR,PSDDAT,PSDDRG,PSDFLG,PSDLN,PSDNAOU,PSDNAOUN,PSDPN1,PSDPN2
K PSDRG,PSDRGN,PSDROU,PSDRQ1,PSDRQ2,PSDTR,PSDTR2,XMDUN,XMDUZ,XMSUB,XMTEXT,XMY
K ^TMP($J,"PSD79P"),^TMP($J,"PSD79P1"),^TMP($J,"PSD79P2"),^TMP($J,"PSD79PR")
Q
DIE ;create the order request
F L +^PSD(58.8,PSDNAOU,1,PSDRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
DIE2 S PSDA=$P(^PSD(58.8,PSDNAOU,1,PSDRG,3,0),"^",3)+1 I $D(^PSD(58.8,PSDNAOU,1,PSDRG,3,PSDA)) S $P(^PSD(58.8,PSDNAOU,1,PSDRG,3,0),"^",3)=$P(^PSD(58.8,PSDNAOU,1,PSDRG,3,0),"^",3)+1 G DIE2
K DA,DIC,DIE,DD,DR,DO S DIC(0)="L",(DIC,DIE)="^PSD(58.8,"_PSDNAOU_",1,"_PSDRG_",3,",DA(2)=PSDNAOU,DA(1)=PSDRG,(X,DINUM)=PSDA D FILE^DICN K DIC
S DA=PSDA,DA(1)=PSDRG,DA(2)=PSDNAOU,DR="1////"_PSDT_";2////"_+PSDS_";3////"_PSDUZ_";4////"_PSDDBY_";5////"_PSDQTY_";6////"_PSDRBY_";7////"_PSDMFR_";8////"_PSDLOT_";9////"_PSDXDT
S DR=DR_";10////"_PSDSTAT_";11////"_PSDCSTAT_";12////"_PSDCDT_";14////"_PSDDDT_";15////"_PSDRDT_";16////"_PSDPN_";17////"_PSDTR_";19////"_PSDRQTY_";20////"_PSDQTY_";22////"
D ^DIE K D,DA,DIE,DIC,DD,DR,DO,DINUM,X
;Saving Comments
N TMP,COMM5881,COMM588 D GETS^DIQ(58.81,PSDTR_",","26","","TMP")
M COMM5881=TMP(58.81,PSDTR_",",26)
I $D(COMM5881(1)) D
. S COMM588(58.800118,PSDA_","_PSDRG_","_PSDNAOU_",",13)="COMM5881"
. D UPDATE^DIE("","COMM588")
L -^PSD(58.8,PSDNAOU,1,PSDRG,0)
F L +^PSD(58.81,PSDTR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
S DIE="^PSD(58.81,",DA=PSDTR,DR="40////"_PSDA
D ^DIE K DIE,DR,DA
L -^PSD(58.81,PSDTR,0)
S ^TMP($J,"PSD79P2",PSDNAOU,PSDRG,PSDTR)=PSDA_"^"_PSDPN_"^"_PSDREQ_"^"_PSDTRN_"^"_$P(^PSD(58.8,PSDNAOU,1,PSDRG,3,PSDREQ,0),"^",16)
Q
MAIL ;CREATE AND SEND MAIL
N DIFROM
S PSDCNTR=PSDCNTR+1,^TMP($J,PSDROU,PSDCNTR)="",PSDCNTR=PSDCNTR+1,^TMP($J,PSDROU,PSDCNTR)="***** End Of Report *****"
S XMTEXT="^TMP($J,"""_PSDROU_""","
N PSDUSR S PSDUSR=.5 F S PSDUSR=$O(^XUSEC("PSDMGR",PSDUSR)) Q:'PSDUSR S XMY(PSDUSR)=""
S XMSUB="PSD*3*79 TRANSACTION REPORT",XMDUZ="PSD*3*79 POST INSTALL"
D ^XMD
Q
NOMAIL ;
S PSDCNTR=1,PSDROU="PSD79PR",PSDLN="",$P(PSDLN,"=",80)=""
S ^TMP($J,PSDROU,PSDCNTR)="",PSDCNTR=PSDCNTR+1
S ^TMP($J,PSDROU,PSDCNTR)="THERE WERE NO TRANSACTIONS TO REPORT."
Q
TXT(PSDVAL,PSDCOL) S:'$D(PSDDAT) PSDDAT="" S PSDDAT=$$SETSTR^VALM1(PSDVAL,PSDDAT,PSDCOL,$L(PSDVAL)) Q
Q
HDR ; MAILMAN REPORT INTRODUCTION
;; This report contains Controlled Substance drugs that assigned multiple
;; Pharmacy Dispensing numbers to a single request number in the Narcotics
;; Area Of Use (NAOU) during order processing.
;;
;; These transactions have been identified and corrected.
;;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSD79P 7586 printed Oct 16, 2024@17:45:34 Page 2
PSD79P ;DAL/RJS - PSD*3*79 DATA FIX ;8/15/12
+1 ;;3.0;DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**79**;10/24/97;Build 20
+2 QUIT
EN ; POST INSTALL ENTRY POINT
+1 ;Identify and fix multiple Pharmacy Dispensing numbers assigned to a single request number in the Narcotics
+2 ;Area Of Use (NAOU) during order processing.
+3 SET ZTDESC="CONTROLLED SUBSTANCES - PSD*3*79 POST INSTALL"
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTRTN="START^PSD79P"
SET ZTSAVE=""
DO ^%ZTLOAD
+4 DO BMES^XPDUTL("PSD*3*79 POST INSTALL Task Queued!")
+5 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+6 QUIT
START ;
+1 KILL ^TMP($JOB,"PSD79P")
+2 NEW PSDPN,PSDTR,PSD81,PSDREQ,PSDNAOU,PSDRG,PSD8
+3 ; Gathering All entries in 58.81 (PSDPN: Pharmacy Dispensing #, PSDTR: Transaction IEN, PSDNAOU: NAOU, PSDREQ: Order Request #, PSDRG: Drug IEN)
+4 SET PSDPN=""
FOR
SET PSDPN=$ORDER(^PSD(58.81,"D",PSDPN))
if PSDPN=""
QUIT
Begin DoDot:1
+5 SET PSDTR=0
FOR
SET PSDTR=$ORDER(^PSD(58.81,"D",PSDPN,PSDTR))
if 'PSDTR
QUIT
Begin DoDot:2
+6 SET PSD81(0)=$GET(^PSD(58.81,PSDTR,0))
SET PSDREQ=$PIECE(PSD81(0),"^",20)
SET PSDNAOU=$PIECE(PSD81(0),"^",18)
SET PSDRG=$PIECE(PSD81(0),"^",5)
+7 IF $GET(PSDNAOU)
IF $GET(PSDRG)
IF $GET(PSDREQ)
Begin DoDot:3
+8 SET ^TMP($JOB,"PSD79P",PSDNAOU,PSDRG,PSDREQ,PSDTR)=""
+9 SET ^TMP($JOB,"PSD79P",PSDNAOU,PSDRG,PSDREQ)=$GET(^TMP($JOB,"PSD79P",PSDNAOU,PSDRG,PSDREQ))+1
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;
+11 KILL ^TMP($JOB,"PSD79P1")
+12 ; Identifying entries with issue (missing 58.8 sub-file correspong record)
+13 SET PSDNAOU=0
FOR
SET PSDNAOU=$ORDER(^TMP($JOB,"PSD79P",PSDNAOU))
if 'PSDNAOU
QUIT
Begin DoDot:1
+14 SET PSDRG=0
FOR
SET PSDRG=$ORDER(^TMP($JOB,"PSD79P",PSDNAOU,PSDRG))
if 'PSDRG
QUIT
Begin DoDot:2
+15 SET PSDREQ=0
FOR
SET PSDREQ=$ORDER(^TMP($JOB,"PSD79P",PSDNAOU,PSDRG,PSDREQ))
if 'PSDREQ
QUIT
Begin DoDot:3
+16 IF $GET(^TMP($JOB,"PSD79P",PSDNAOU,PSDRG,PSDREQ))>1
Begin DoDot:4
+17 SET PSDTR=0
FOR
SET PSDTR=$ORDER(^TMP($JOB,"PSD79P",PSDNAOU,PSDRG,PSDREQ,PSDTR))
if 'PSDTR
QUIT
Begin DoDot:5
+18 SET PSD8(0)=$GET(^PSD(58.8,PSDNAOU,1,PSDRG,3,PSDREQ,0))
IF $PIECE(PSD8(0),"^",17)=""
QUIT
+19 IF PSDTR'=$PIECE(PSD8(0),"^",17)
SET ^TMP($JOB,"PSD79P1",PSDNAOU,PSDRG,PSDTR)=PSDREQ_"^"_$PIECE(PSD8(0),"^",17)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;
+21 KILL ^TMP($JOB,"PSD79P2")
+22 ; Fixing entries with issue (missing 58.8 sub-file correspong record)
+23 SET PSDNAOU=0
FOR
SET PSDNAOU=$ORDER(^TMP($JOB,"PSD79P1",PSDNAOU))
if 'PSDNAOU
QUIT
Begin DoDot:1
+24 SET PSDRG=0
FOR
SET PSDRG=$ORDER(^TMP($JOB,"PSD79P1",PSDNAOU,PSDRG))
if 'PSDRG
QUIT
Begin DoDot:2
+25 SET PSDTR=0
FOR
SET PSDTR=$ORDER(^TMP($JOB,"PSD79P1",PSDNAOU,PSDRG,PSDTR))
if 'PSDTR
QUIT
Begin DoDot:3
+26 SET PSDREQ=$PIECE($GET(^TMP($JOB,"PSD79P1",PSDNAOU,PSDRG,PSDTR)),"^",1)
SET PSDTRN=$PIECE($GET(^TMP($JOB,"PSD79P1",PSDNAOU,PSDRG,PSDTR)),"^",2)
+27 SET PSD81(0)=$GET(^PSD(58.81,PSDTR,0))
SET PSDPN=$PIECE(PSD81(0),"^",17)
SET PSD81(1)=$GET(^PSD(58.81,PSDTR,1))
+28 SET PSD8(0)=$GET(^PSD(58.8,PSDNAOU,1,PSDRG,3,PSDREQ,0))
SET PSDRQ=$PIECE($GET(^PSD(58.8,PSDNAOU,1,PSDRG,3,0)),"^",3)
+29 SET PSDS=$PIECE(PSD81(0),"^",3)
SET PSDQTY=$PIECE(PSD81(0),"^",6)
SET PSDSTAT=$PIECE(PSD81(0),"^",11)
SET PSDMFR=$PIECE(PSD81(0),"^",13)
+30 SET PSDDDT=$PIECE(PSD81(0),"^",4)
+31 SET PSDLOT=$PIECE(PSD81(0),"^",14)
SET PSDXDT=$PIECE(PSD81(0),"^",15)
SET PSDCSTAT=$PIECE(PSD81(0),"^",12)
SET PSDCDT=$PIECE(PSD81(0),"^",19)
+32 SET PSDDBY=$PIECE(PSD81(1),"^",1)
SET PSDRBY=$PIECE(PSD81(1),"^",3)
SET PSDT=$PIECE(PSD81(1),"^",6)
SET PSDUZ=$PIECE(PSD81(1),"^",7)
+33 SET PSDRDT=$PIECE(PSD81(1),"^",4)
SET PSDRQTY=$PIECE(PSD81(1),"^",8)
+34 DO DIE
End DoDot:3
End DoDot:2
End DoDot:1
+35 ;
+36 ; Generating Mailman message with entries cleaned up or No transactions to report message
+37 KILL D,D0,DI,DIC,DQ,PSD8,PSD81,PSDA,PSDCDT,PSDCNT,PSDCSTAT,PSDDBY,PSDDDT,PSDLOT,PSDMFR,PSDNAOU,PSDPN
+38 KILL PSDQTY,PSDRBY,PSDRDT,PSDREQ,PSDRQ,PSDRQTY,PSDS,PSDSTAT,PSDT,PSDTR,PSDTRN,PSDUZ,PSDXDT,X
+39 IF '$DATA(^TMP($JOB,"PSD79P1"))
DO NOMAIL
DO MAIL
QUIT
+40 SET PSDCNTR=1
SET PSDROU="PSD79PR"
SET PSDLN=""
SET $PIECE(PSDLN,"=",80)=""
+41 KILL PSD1,PSD2
FOR PSD3=1:1
SET PSD1=$TEXT(HDR+PSD3)
if PSD1[";;END"
QUIT
SET PSD2=$PIECE(PSD1,";;",2)
SET PSD2(PSD3,0)=PSD1
SET ^TMP($JOB,PSDROU,PSDCNTR)=PSD2
SET PSDCNTR=PSDCNTR+1
+42 SET ^TMP($JOB,PSDROU,PSDCNTR)=""
SET PSDCNTR=PSDCNTR+1
+43 SET PSDDAT=""
DO TXT("NAOU",0)
DO TXT("Pharmacy",44)
DO TXT("Transaction",55)
DO TXT("Old",70)
DO TXT("/",73)
DO TXT("New",74)
+44 SET ^TMP($JOB,PSDROU,PSDCNTR)=PSDDAT
SET PSDCNTR=PSDCNTR+1
+45 SET PSDDAT=""
DO TXT("Drug Name",2)
DO TXT("Dispensing #",43)
DO TXT("Number",58)
DO TXT("Request #",69)
+46 SET ^TMP($JOB,PSDROU,PSDCNTR)=PSDDAT
SET PSDCNTR=PSDCNTR+1
+47 SET ^TMP($JOB,PSDROU,PSDCNTR)=PSDLN
SET PSDCNTR=PSDCNTR+1
+48 SET PSDNAOU=0
FOR
SET PSDNAOU=$ORDER(^TMP($JOB,"PSD79P2",PSDNAOU))
if 'PSDNAOU
QUIT
Begin DoDot:1
+49 SET PSDNAOUN=$PIECE(^PSD(58.8,PSDNAOU,0),"^",1)
SET ^TMP($JOB,PSDROU,PSDCNTR)=PSDNAOUN
SET PSDCNTR=PSDCNTR+1
+50 SET PSDDRG=0
FOR
SET PSDRG=$ORDER(^TMP($JOB,"PSD79P2",PSDNAOU,PSDRG))
if 'PSDRG
QUIT
Begin DoDot:2
+51 SET PSDFLG=0
SET PSDRGN=$PIECE(^PSDRUG(PSDRG,0),"^",1)
IF $LENGTH(PSDRGN)>40
SET PSDRGN=$EXTRACT(PSDRGN,1,45)
+52 SET PSDTR=0
FOR
SET PSDTR=$ORDER(^TMP($JOB,"PSD79P2",PSDNAOU,PSDRG,PSDTR))
if 'PSDTR
QUIT
Begin DoDot:3
+53 if 'PSDFLG
SET PSDDAT=""
DO TXT(PSDRGN,2)
+54 SET PSD0=$GET(^TMP($JOB,"PSD79P2",PSDNAOU,PSDRG,PSDTR))
+55 SET PSDPN1=$PIECE(PSD0,"^",2)
SET PSDRQ1=$PIECE(PSD0,"^",1)
SET PSDRQ2=$PIECE(PSD0,"^",3)
+56 SET PSDPN2=$PIECE(PSD0,"^",5)
SET PSDTR2=$PIECE(PSD0,"^",4)
+57 if PSDFLG
SET PSDDAT=""
DO TXT(PSDPN1,45)
DO TXT(PSDTR,57)
DO TXT(PSDRQ2,(73-$LENGTH(PSDRQ2)))
DO TXT("/",73)
DO TXT(PSDRQ1,74)
+58 SET ^TMP($JOB,PSDROU,PSDCNTR)=PSDDAT
SET PSDCNTR=PSDCNTR+1
SET PSDFLG=1
+59 SET PSDDAT=""
DO TXT(PSDPN2,45)
DO TXT(PSDTR2,57)
DO TXT(PSDRQ2,(73-$LENGTH(PSDRQ2)))
DO TXT("/",73)
DO TXT("NA",74)
+60 SET ^TMP($JOB,PSDROU,PSDCNTR)=PSDDAT
SET PSDCNTR=PSDCNTR+1
+61 SET ^TMP($JOB,PSDROU,PSDCNTR)=""
SET PSDCNTR=PSDCNTR+1
KILL PSDATA
End DoDot:3
End DoDot:2
End DoDot:1
+62 DO MAIL
+63 ;
EXIT ;
+1 KILL PSD0,PSD3,PSDCNTR,PSDDAT,PSDDRG,PSDFLG,PSDLN,PSDNAOU,PSDNAOUN,PSDPN1,PSDPN2
+2 KILL PSDRG,PSDRGN,PSDROU,PSDRQ1,PSDRQ2,PSDTR,PSDTR2,XMDUN,XMDUZ,XMSUB,XMTEXT,XMY
+3 KILL ^TMP($JOB,"PSD79P"),^TMP($JOB,"PSD79P1"),^TMP($JOB,"PSD79P2"),^TMP($JOB,"PSD79PR")
+4 QUIT
DIE ;create the order request
+1 FOR
LOCK +^PSD(58.8,PSDNAOU,1,PSDRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
DIE2 SET PSDA=$PIECE(^PSD(58.8,PSDNAOU,1,PSDRG,3,0),"^",3)+1
IF $DATA(^PSD(58.8,PSDNAOU,1,PSDRG,3,PSDA))
SET $PIECE(^PSD(58.8,PSDNAOU,1,PSDRG,3,0),"^",3)=$PIECE(^PSD(58.8,PSDNAOU,1,PSDRG,3,0),"^",3)+1
GOTO DIE2
+1 KILL DA,DIC,DIE,DD,DR,DO
SET DIC(0)="L"
SET (DIC,DIE)="^PSD(58.8,"_PSDNAOU_",1,"_PSDRG_",3,"
SET DA(2)=PSDNAOU
SET DA(1)=PSDRG
SET (X,DINUM)=PSDA
DO FILE^DICN
KILL DIC
+2 SET DA=PSDA
SET DA(1)=PSDRG
SET DA(2)=PSDNAOU
SET DR="1////"_PSDT_";2////"_+PSDS_";3////"_PSDUZ_";4////"_PSDDBY_";5////"_PSDQTY_";6////"_PSDRBY_";7////"_PSDMFR_";8////"_PSDLOT_";9////"_PSDXDT
+3 SET DR=DR_";10////"_PSDSTAT_";11////"_PSDCSTAT_";12////"_PSDCDT_";14////"_PSDDDT_";15////"_PSDRDT_";16////"_PSDPN_";17////"_PSDTR_";19////"_PSDRQTY_";20////"_PSDQTY_";22////"
+4 DO ^DIE
KILL D,DA,DIE,DIC,DD,DR,DO,DINUM,X
+5 ;Saving Comments
+6 NEW TMP,COMM5881,COMM588
DO GETS^DIQ(58.81,PSDTR_",","26","","TMP")
+7 MERGE COMM5881=TMP(58.81,PSDTR_",",26)
+8 IF $DATA(COMM5881(1))
Begin DoDot:1
+9 SET COMM588(58.800118,PSDA_","_PSDRG_","_PSDNAOU_",",13)="COMM5881"
+10 DO UPDATE^DIE("","COMM588")
End DoDot:1
+11 LOCK -^PSD(58.8,PSDNAOU,1,PSDRG,0)
+12 FOR
LOCK +^PSD(58.81,PSDTR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+13 SET DIE="^PSD(58.81,"
SET DA=PSDTR
SET DR="40////"_PSDA
+14 DO ^DIE
KILL DIE,DR,DA
+15 LOCK -^PSD(58.81,PSDTR,0)
+16 SET ^TMP($JOB,"PSD79P2",PSDNAOU,PSDRG,PSDTR)=PSDA_"^"_PSDPN_"^"_PSDREQ_"^"_PSDTRN_"^"_$PIECE(^PSD(58.8,PSDNAOU,1,PSDRG,3,PSDREQ,0),"^",16)
+17 QUIT
MAIL ;CREATE AND SEND MAIL
+1 NEW DIFROM
+2 SET PSDCNTR=PSDCNTR+1
SET ^TMP($JOB,PSDROU,PSDCNTR)=""
SET PSDCNTR=PSDCNTR+1
SET ^TMP($JOB,PSDROU,PSDCNTR)="***** End Of Report *****"
+3 SET XMTEXT="^TMP($J,"""_PSDROU_""","
+4 NEW PSDUSR
SET PSDUSR=.5
FOR
SET PSDUSR=$ORDER(^XUSEC("PSDMGR",PSDUSR))
if 'PSDUSR
QUIT
SET XMY(PSDUSR)=""
+5 SET XMSUB="PSD*3*79 TRANSACTION REPORT"
SET XMDUZ="PSD*3*79 POST INSTALL"
+6 DO ^XMD
+7 QUIT
NOMAIL ;
+1 SET PSDCNTR=1
SET PSDROU="PSD79PR"
SET PSDLN=""
SET $PIECE(PSDLN,"=",80)=""
+2 SET ^TMP($JOB,PSDROU,PSDCNTR)=""
SET PSDCNTR=PSDCNTR+1
+3 SET ^TMP($JOB,PSDROU,PSDCNTR)="THERE WERE NO TRANSACTIONS TO REPORT."
+4 QUIT
TXT(PSDVAL,PSDCOL) if '$DATA(PSDDAT)
SET PSDDAT=""
SET PSDDAT=$$SETSTR^VALM1(PSDVAL,PSDDAT,PSDCOL,$LENGTH(PSDVAL))
QUIT
+1 QUIT
HDR ; MAILMAN REPORT INTRODUCTION
+1 ;; This report contains Controlled Substance drugs that assigned multiple
+2 ;; Pharmacy Dispensing numbers to a single request number in the Narcotics
+3 ;; Area Of Use (NAOU) during order processing.
+4 ;;
+5 ;; These transactions have been identified and corrected.
+6 ;;END
