- 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 Mar 13, 2025@20:49:24 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
