PSAPRE71 ;BIR/RJS-PRE-INSTALL TO IDENTIFY BAD 58.8 DRUG POINTERS
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**71**;;Build 10
;;
N X1,X2,Y,PSADT,PSALOC,PSADAT,PSADRG,PSACNTR,PSAFND,PSAIEN,PSAIN,PSAINV,PSAORD,PSAPRO,PSARDT,PSAROU,PSAVDT,PSAVER,XMDUZ,XMSUB,XMTEXT,XMY
S PSAROU="PSALCK"
S PSACNTR=1,PSAFND=0
S ^TMP($J,PSAROU,PSACNTR)="The following Drug Accountability Order Invoices currently",PSACNTR=PSACNTR+1
S ^TMP($J,PSAROU,PSACNTR)="have a status of LOCKED VERIFYING.",PSACNTR=PSACNTR+1
S ^TMP($J,PSAROU,PSACNTR)=" ",PSACNTR=PSACNTR+1
S PSADAT="" D TXT("Order#",1),TXT("Invoice#",20),TXT("Date Received",40),TXT("Verifier",60)
S ^TMP($J,PSAROU,PSACNTR)=PSADAT,PSACNTR=PSACNTR+1
S PSAIEN=0 F S PSAIEN=$O(^PSD(58.811,"ASTAT","L",PSAIEN)) Q:'PSAIEN D
.S PSAINV=0 F S PSAINV=$O(^PSD(58.811,"ASTAT","L",PSAIEN,PSAINV)) Q:'PSAINV D
..S PSAVDT=+$P(^PSD(58.811,PSAIEN,1,PSAINV,1,1,0),"^",8),PSARDT=+$P(^PSD(58.811,PSAIEN,1,PSAINV,0),"^",7)
..S PSAORD=$P(^PSD(58.811,PSAIEN,0),"^",1),PSAIN=$P(^PSD(58.811,PSAIEN,1,PSAINV,0),"^",1)
..S Y=PSARDT D DD^%DT S PSADT=Y
..I '$P($G(^PSD(58.811,PSAIEN,1,PSAINV,0)),"^",11) D UNLCK Q
..S PSAVER=$P(^VA(200,$P(^PSD(58.811,PSAIEN,1,PSAINV,0),"^",11),0),"^",1)
..S PSADAT="" D TXT(PSAORD,1),TXT(PSAIN,20),TXT(PSADT,40),TXT(PSAVER,60)
..S ^TMP($J,PSAROU,PSACNTR)=PSADAT,PSACNTR=PSACNTR+1,PSAFND=1
..S ^XTMP(PSAROU,$P(^PSD(58.811,PSAIEN,1,PSAINV,0),"^",11),PSAIEN,PSAINV)=""
I $G(PSAFND) S X1=DT,X2=60 D C^%DTC S ^XTMP(PSAROU,0)=X_"^"_DT_"^PSA*3*71 LOCKED INVOICES"
I 'PSAFND S ^TMP($J,PSAROU,PSACNTR)="No Locked Invoices Found.",PSACNTR=PSACNTR+1,^TMP($J,PSAROU,PSACNTR)="",PSACNTR=PSACNTR+1
S PSACNTR=PSACNTR+1,^TMP($J,PSAROU,PSACNTR)="",PSACNTR=PSACNTR+1
S XMSUB="PSA*3*71 LOCKED INVOICE REPORT",XMDUZ="PSA*3*71 PREINSTALL"
D MAIL
S PSAROU="PSACHK"
D NOW^%DTC S Y=% D DD^%DT S PSADT=$P(Y,"@",1)_" at "_$P(Y,"@",2)
S ^TMP(PSAROU,$J,0)=PSADT
S PSALOC=0 F S PSALOC=$O(^PSD(58.8,PSALOC)) Q:'PSALOC D
.S PSADRG=99999999 F S PSADRG=$O(^PSD(58.8,PSALOC,1,PSADRG)) Q:PSADRG="" D
..Q:PSADRG="B"
..I $L(PSADRG)'=$L(+PSADRG) S ^TMP(PSAROU,$J,PSALOC,PSADRG)="" K ^PSD(58.8,PSALOC,1,PSADRG,0)
S XMSUB="PSA*3*71 PREINSTALL BAD 58.8 RECORD REPORT",XMDUZ="PSA*3*71 PREINSTALL"
S PSACNTR=1,^TMP($J,PSAROU,PSACNTR)="PSA*3*71 PREINSTALL Bad PSD(58.8 Record Report for "_PSADT,PSACNTR=PSACNTR+1
S ^TMP($J,PSAROU,PSACNTR)=" ",PSACNTR=PSACNTR+1
I '$O(^TMP(PSAROU,$J,0)) S ^TMP($J,PSAROU,PSACNTR)="No Bad Records found.",PSACNTR=PSACNTR+1,^TMP($J,PSAROU,PSACNTR)="",PSACNTR=PSACNTR+1 G MAIL
S PSALOC=0 F S PSALOC=$O(^TMP(PSAROU,$J,PSALOC)) Q:'PSALOC D
.S PSACNTR=PSACNTR+1,^TMP($J,PSAROU,PSACNTR)=$P(^PSD(58.8,PSALOC,0),"^")
.S PSADRG=0 F S PSADRG=$O(^TMP(PSAROU,$J,PSALOC,PSADRG)) Q:PSADRG="" D
..S PSACNTR=PSACNTR+1,^TMP($J,PSAROU,PSACNTR)=" "_PSADRG
.S PSACNTR=PSACNTR+1,^TMP($J,PSAROU,PSACNTR)="",PSACNTR=PSACNTR+1,^TMP($J,PSAROU,PSACNTR)=" *** These have been removed from the file.***",PSACNTR=PSACNTR+1,^TMP($J,PSAROU,PSACNTR)=""
S PSACNTR=PSACNTR+1,^TMP($J,PSAROU,PSACNTR)="",PSACNTR=PSACNTR+1
MAIL N DIFROM
S PSACNTR=PSACNTR+1,^TMP($J,PSAROU,PSACNTR)="***** End Of Report *****"
S XMTEXT="^TMP($J,"""_PSAROU_""","
S XMY("G.PSA NDC UPDATES")=""
D ^XMD
Q
EXIT ; CLEAN UP
K ^TMP($J),^TMP(PSAROU)
Q
TXT(PSAVAL,PSACOL) S:'$D(PSADAT) PSADAT="" S PSADAT=$$SETSTR^VALM1(PSAVAL,PSADAT,PSACOL,$L(PSAVAL)) Q
Q
UNLCK ; UNLOCK BACK LOCK
F L +^PSD(58.811,PSAIEN,1,PSAINV,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
S DA=PSAINV,DA(1)=PSAIEN,DIE="^PSD(58.811,"_DA(1)_",1,",DR="2///P" D ^DIE
L -^PSD(58.811,PSAIEN,1,PSAINV,0)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAPRE71 3662 printed Nov 22, 2024@17:00:13 Page 2
PSAPRE71 ;BIR/RJS-PRE-INSTALL TO IDENTIFY BAD 58.8 DRUG POINTERS
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**71**;;Build 10
+2 ;;
+3 NEW X1,X2,Y,PSADT,PSALOC,PSADAT,PSADRG,PSACNTR,PSAFND,PSAIEN,PSAIN,PSAINV,PSAORD,PSAPRO,PSARDT,PSAROU,PSAVDT,PSAVER,XMDUZ,XMSUB,XMTEXT,XMY
+4 SET PSAROU="PSALCK"
+5 SET PSACNTR=1
SET PSAFND=0
+6 SET ^TMP($JOB,PSAROU,PSACNTR)="The following Drug Accountability Order Invoices currently"
SET PSACNTR=PSACNTR+1
+7 SET ^TMP($JOB,PSAROU,PSACNTR)="have a status of LOCKED VERIFYING."
SET PSACNTR=PSACNTR+1
+8 SET ^TMP($JOB,PSAROU,PSACNTR)=" "
SET PSACNTR=PSACNTR+1
+9 SET PSADAT=""
DO TXT("Order#",1)
DO TXT("Invoice#",20)
DO TXT("Date Received",40)
DO TXT("Verifier",60)
+10 SET ^TMP($JOB,PSAROU,PSACNTR)=PSADAT
SET PSACNTR=PSACNTR+1
+11 SET PSAIEN=0
FOR
SET PSAIEN=$ORDER(^PSD(58.811,"ASTAT","L",PSAIEN))
if 'PSAIEN
QUIT
Begin DoDot:1
+12 SET PSAINV=0
FOR
SET PSAINV=$ORDER(^PSD(58.811,"ASTAT","L",PSAIEN,PSAINV))
if 'PSAINV
QUIT
Begin DoDot:2
+13 SET PSAVDT=+$PIECE(^PSD(58.811,PSAIEN,1,PSAINV,1,1,0),"^",8)
SET PSARDT=+$PIECE(^PSD(58.811,PSAIEN,1,PSAINV,0),"^",7)
+14 SET PSAORD=$PIECE(^PSD(58.811,PSAIEN,0),"^",1)
SET PSAIN=$PIECE(^PSD(58.811,PSAIEN,1,PSAINV,0),"^",1)
+15 SET Y=PSARDT
DO DD^%DT
SET PSADT=Y
+16 IF '$PIECE($GET(^PSD(58.811,PSAIEN,1,PSAINV,0)),"^",11)
DO UNLCK
QUIT
+17 SET PSAVER=$PIECE(^VA(200,$PIECE(^PSD(58.811,PSAIEN,1,PSAINV,0),"^",11),0),"^",1)
+18 SET PSADAT=""
DO TXT(PSAORD,1)
DO TXT(PSAIN,20)
DO TXT(PSADT,40)
DO TXT(PSAVER,60)
+19 SET ^TMP($JOB,PSAROU,PSACNTR)=PSADAT
SET PSACNTR=PSACNTR+1
SET PSAFND=1
+20 SET ^XTMP(PSAROU,$PIECE(^PSD(58.811,PSAIEN,1,PSAINV,0),"^",11),PSAIEN,PSAINV)=""
End DoDot:2
End DoDot:1
+21 IF $GET(PSAFND)
SET X1=DT
SET X2=60
DO C^%DTC
SET ^XTMP(PSAROU,0)=X_"^"_DT_"^PSA*3*71 LOCKED INVOICES"
+22 IF 'PSAFND
SET ^TMP($JOB,PSAROU,PSACNTR)="No Locked Invoices Found."
SET PSACNTR=PSACNTR+1
SET ^TMP($JOB,PSAROU,PSACNTR)=""
SET PSACNTR=PSACNTR+1
+23 SET PSACNTR=PSACNTR+1
SET ^TMP($JOB,PSAROU,PSACNTR)=""
SET PSACNTR=PSACNTR+1
+24 SET XMSUB="PSA*3*71 LOCKED INVOICE REPORT"
SET XMDUZ="PSA*3*71 PREINSTALL"
+25 DO MAIL
+26 SET PSAROU="PSACHK"
+27 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET PSADT=$PIECE(Y,"@",1)_" at "_$PIECE(Y,"@",2)
+28 SET ^TMP(PSAROU,$JOB,0)=PSADT
+29 SET PSALOC=0
FOR
SET PSALOC=$ORDER(^PSD(58.8,PSALOC))
if 'PSALOC
QUIT
Begin DoDot:1
+30 SET PSADRG=99999999
FOR
SET PSADRG=$ORDER(^PSD(58.8,PSALOC,1,PSADRG))
if PSADRG=""
QUIT
Begin DoDot:2
+31 if PSADRG="B"
QUIT
+32 IF $LENGTH(PSADRG)'=$LENGTH(+PSADRG)
SET ^TMP(PSAROU,$JOB,PSALOC,PSADRG)=""
KILL ^PSD(58.8,PSALOC,1,PSADRG,0)
End DoDot:2
End DoDot:1
+33 SET XMSUB="PSA*3*71 PREINSTALL BAD 58.8 RECORD REPORT"
SET XMDUZ="PSA*3*71 PREINSTALL"
+34 SET PSACNTR=1
SET ^TMP($JOB,PSAROU,PSACNTR)="PSA*3*71 PREINSTALL Bad PSD(58.8 Record Report for "_PSADT
SET PSACNTR=PSACNTR+1
+35 SET ^TMP($JOB,PSAROU,PSACNTR)=" "
SET PSACNTR=PSACNTR+1
+36 IF '$ORDER(^TMP(PSAROU,$JOB,0))
SET ^TMP($JOB,PSAROU,PSACNTR)="No Bad Records found."
SET PSACNTR=PSACNTR+1
SET ^TMP($JOB,PSAROU,PSACNTR)=""
SET PSACNTR=PSACNTR+1
GOTO MAIL
+37 SET PSALOC=0
FOR
SET PSALOC=$ORDER(^TMP(PSAROU,$JOB,PSALOC))
if 'PSALOC
QUIT
Begin DoDot:1
+38 SET PSACNTR=PSACNTR+1
SET ^TMP($JOB,PSAROU,PSACNTR)=$PIECE(^PSD(58.8,PSALOC,0),"^")
+39 SET PSADRG=0
FOR
SET PSADRG=$ORDER(^TMP(PSAROU,$JOB,PSALOC,PSADRG))
if PSADRG=""
QUIT
Begin DoDot:2
+40 SET PSACNTR=PSACNTR+1
SET ^TMP($JOB,PSAROU,PSACNTR)=" "_PSADRG
End DoDot:2
+41 SET PSACNTR=PSACNTR+1
SET ^TMP($JOB,PSAROU,PSACNTR)=""
SET PSACNTR=PSACNTR+1
SET ^TMP($JOB,PSAROU,PSACNTR)=" *** These have been removed from the file.***"
SET PSACNTR=PSACNTR+1
SET ^TMP($JOB,PSAROU,PSACNTR)=""
End DoDot:1
+42 SET PSACNTR=PSACNTR+1
SET ^TMP($JOB,PSAROU,PSACNTR)=""
SET PSACNTR=PSACNTR+1
MAIL NEW DIFROM
+1 SET PSACNTR=PSACNTR+1
SET ^TMP($JOB,PSAROU,PSACNTR)="***** End Of Report *****"
+2 SET XMTEXT="^TMP($J,"""_PSAROU_""","
+3 SET XMY("G.PSA NDC UPDATES")=""
+4 DO ^XMD
+5 QUIT
EXIT ; CLEAN UP
+1 KILL ^TMP($JOB),^TMP(PSAROU)
+2 QUIT
TXT(PSAVAL,PSACOL) if '$DATA(PSADAT)
SET PSADAT=""
SET PSADAT=$$SETSTR^VALM1(PSAVAL,PSADAT,PSACOL,$LENGTH(PSAVAL))
QUIT
+1 QUIT
UNLCK ; UNLOCK BACK LOCK
+1 FOR
LOCK +^PSD(58.811,PSAIEN,1,PSAINV,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+2 SET DA=PSAINV
SET DA(1)=PSAIEN
SET DIE="^PSD(58.811,"_DA(1)_",1,"
SET DR="2///P"
DO ^DIE
+3 LOCK -^PSD(58.811,PSAIEN,1,PSAINV,0)
+4 QUIT
