PSXDODAK ;BIR/PDW-FILE .QACs FACILITY RELEASE PROCESSED ACKs & NAKs ;09/09/02 10:45 AM
;;2.0;CMOP;**38,45**;11 Apr 97
EN(PATH,FNAME) ; needs directory & file name
; force an error in the next line
;S X=ERROR ; generate an undefined error
D EXIT
I $L(PATH),$L(FNAME) I 1
E S PSXERR="0^BAD PATH OR FILENAME" G ERRMSG
K ^TMP($J,"PSXDOD")
S GBL="^TMP("_$J_",""PSXDOD"",1)"
S Y=$$FTG^%ZISH(PATH,FNAME,GBL,3)
I Y'>0 S PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD" G ERRMSG
I $D(^TMP($J,"PSXDOD"))'>1 S PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD" G ERRMSG
S FHS=^TMP($J,"PSXDOD",1),BHS=^TMP($J,"PSXDOD",2)
I $E(FHS,1,3)="FHS",$E(BHS,1,3)="BHS" I 1
E S PSXERR="1^File headers not correct ^"_FNAME Q
; setup variables to call into PSXVEND for filing acks and nacks
;BHS|^~\&|CHCS|VistA|20020417081343||||0617-021081441
F YY="PDT^5","MSG^9" D PIECE(BHS,"|",YY)
S (PSXPDT,PDT)=$$FMDATE^HLFNC(PDT),TXMZ="1"_MSG
;MSGNUM is to be the same ID of the release message .qry the .qac is responding to
S SS="1"_$P(MSG,"-"),MSGNUM=$P(MSG,"-",2)
D NOW^%DTC S ACKTM=%
I $E(IOST)="C" W !,"UPDATING ",MSGNUM
D DOD^PSXVEND ; update 554 message status
;
F LNNUM=3:1 S LN=$G(^TMP($J,"PSXDOD",LNNUM)) Q:LN="" S SEG=$E(LN,1,3) Q:SEG="BTS" D:SEG="MSA" MSA
;
EXIT ;
K ^TMP($J,"PSXDOD")
K FHS,BHS,PDT,MSG,TXMZ,MSGNUM,HOLD
Q
MSA ; pull variables from MSA segment and call into PSXVEND $RX or $INV
;MSA|CA|0617-AA116-2|
;MSA|CR|516-11450-8954|2-RX ENTRY MISSING
I $E(IOST)="C" W !,LN
F YY="TYP^2","RXNDX^3","STAT^4" D PIECE(LN,"|",YY)
S RXNDX="1"_RXNDX,(RXN,RXNUM)=$P(RXNDX,"-",2),FILL=$P(RXNDX,"-",3),STAT=+STAT
I '$D(^PSX(552.4,"E",RXNDX)) S PSXERR=".QAC RX Not Found "_RXNDX_" "_FNAME D ERRMSG Q
S AA=$O(^PSX(552.4,"E",RXNDX,0)),BB=$O(^PSX(552.4,"E",RXNDX,AA,0))
I $E(IOST)="C" W !,"ENTRY AA BB ",AA," ",BB
I AA,BB I 1
E S PSXERR="QAC RX Entry Not Found "_RXNDX_" "_FNAME D ERRMSG Q
S SS="1"_$P(MSG,"-"),PDT=PSXPDT
K DIC,DA,DR,DIE,DO,DD
D:TYP="CA" DODRX^PSXVEND
D:TYP="CR" DODINV^PSXVEND
Q
PIECE(REC,DLM,XX) ;
; Set variable V = piece P of REC using delimiter DLM
N V,P S V=$P(XX,U),P=$P(XX,U,2),@V=$P(REC,DLM,P)
Q
PUT(REC,DLM,XX) ;
; Set Variable V into piece P of REC using delimiter DLM
N V,P S V=$P(XX,U),P=$P(XX,U,2)
S $P(REC,DLM,P)=$G(@V)
Q
ERRMSG ;send error message to folks & DOD
S DIRHOLD=$$GET1^DIQ(554,1,23),HOLD=$G(HOLD)+1
I HOLD=1 D
. F XX=1:1:5 S Y=$$GTF^%ZISH($NA(^TMP($J,"PSXDOD",1)),3,DIRHOLD,FNAME) Q:Y=1 H 4
. I Y'=1 S GBL=$NA(^TMP($J,"PSXDOD")) D FALERT^PSXDODNT(FNAME,DIRHOLD,GBL)
S XMSUB="DOD CMOP Error "_FNAME
;S XMY(DUZ)="" ;***TESTING
S XMY("G.PSXX CMOP MANAGERS")=""
S XMTEXT="PSXTXT("
S PSXTXT(1,0)="DOD CMOP .QAC Facility Release Acknowledgement filing experienced an error"
S PSXTXT(2,0)=$G(PSXERR)
S PSXTXT(3,0)="FILE: "_FNAME
S PSXTXT(4,0)="A copy of the file has been placed in the hold directory "_DIRHOLD
D ^XMD
I $E(IOST)="C" W ! F I=1:1:4 W !,PSXTXT(I,0) I I=4 H 3
K PSXTXT,DIRHOLD
Q
RXNDX ; backfill the RX multiple RXNDX field #40 of file 552.4
S ORDDA=0 F S ORDDA=$O(^PSX(552.4,ORDDA)) Q:ORDDA'>0 D
. S SITE=$$GET1^DIQ(552.4,ORDDA,.01),SITE=$P(SITE,"-")
. S RXDA=0 F S RXDA=$O(^PSX(552.4,ORDDA,1,RXDA)) Q:RXDA'>0 S XX=^(RXDA,0) D
.. F YY="RXNM^1","FILL^12" D PIECE(XX,U,YY)
.. S FILL=FILL+1,VAL=SITE_"-"_RXNM_"-"_FILL
.. K DR,DIE,DA
.. S DIE="^PSX(552.4,"_ORDDA_",1,",DA(1)=ORDDA,DA=RXDA,DR="40///^S X=VAL"
.. D ^DIE K DR,DIE,DA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXDODAK 3508 printed Apr 09, 2024@20:49:11 Page 2
PSXDODAK ;BIR/PDW-FILE .QACs FACILITY RELEASE PROCESSED ACKs & NAKs ;09/09/02 10:45 AM
+1 ;;2.0;CMOP;**38,45**;11 Apr 97
EN(PATH,FNAME) ; needs directory & file name
+1 ; force an error in the next line
+2 ;S X=ERROR ; generate an undefined error
+3 DO EXIT
+4 IF $LENGTH(PATH)
IF $LENGTH(FNAME)
IF 1
+5 IF '$TEST
SET PSXERR="0^BAD PATH OR FILENAME"
GOTO ERRMSG
+6 KILL ^TMP($JOB,"PSXDOD")
+7 SET GBL="^TMP("_$JOB_",""PSXDOD"",1)"
+8 SET Y=$$FTG^%ZISH(PATH,FNAME,GBL,3)
+9 IF Y'>0
SET PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD"
GOTO ERRMSG
+10 IF $DATA(^TMP($JOB,"PSXDOD"))'>1
SET PSXERR="9^"_PATH_U_FNAME_U_" DID NOT LOAD"
GOTO ERRMSG
+11 SET FHS=^TMP($JOB,"PSXDOD",1)
SET BHS=^TMP($JOB,"PSXDOD",2)
+12 IF $EXTRACT(FHS,1,3)="FHS"
IF $EXTRACT(BHS,1,3)="BHS"
IF 1
+13 IF '$TEST
SET PSXERR="1^File headers not correct ^"_FNAME
QUIT
+14 ; setup variables to call into PSXVEND for filing acks and nacks
+15 ;BHS|^~\&|CHCS|VistA|20020417081343||||0617-021081441
+16 FOR YY="PDT^5","MSG^9"
DO PIECE(BHS,"|",YY)
+17 SET (PSXPDT,PDT)=$$FMDATE^HLFNC(PDT)
SET TXMZ="1"_MSG
+18 ;MSGNUM is to be the same ID of the release message .qry the .qac is responding to
+19 SET SS="1"_$PIECE(MSG,"-")
SET MSGNUM=$PIECE(MSG,"-",2)
+20 DO NOW^%DTC
SET ACKTM=%
+21 IF $EXTRACT(IOST)="C"
WRITE !,"UPDATING ",MSGNUM
+22 ; update 554 message status
DO DOD^PSXVEND
+23 ;
+24 FOR LNNUM=3:1
SET LN=$GET(^TMP($JOB,"PSXDOD",LNNUM))
if LN=""
QUIT
SET SEG=$EXTRACT(LN,1,3)
if SEG="BTS"
QUIT
if SEG="MSA"
DO MSA
+25 ;
EXIT ;
+1 KILL ^TMP($JOB,"PSXDOD")
+2 KILL FHS,BHS,PDT,MSG,TXMZ,MSGNUM,HOLD
+3 QUIT
MSA ; pull variables from MSA segment and call into PSXVEND $RX or $INV
+1 ;MSA|CA|0617-AA116-2|
+2 ;MSA|CR|516-11450-8954|2-RX ENTRY MISSING
+3 IF $EXTRACT(IOST)="C"
WRITE !,LN
+4 FOR YY="TYP^2","RXNDX^3","STAT^4"
DO PIECE(LN,"|",YY)
+5 SET RXNDX="1"_RXNDX
SET (RXN,RXNUM)=$PIECE(RXNDX,"-",2)
SET FILL=$PIECE(RXNDX,"-",3)
SET STAT=+STAT
+6 IF '$DATA(^PSX(552.4,"E",RXNDX))
SET PSXERR=".QAC RX Not Found "_RXNDX_" "_FNAME
DO ERRMSG
QUIT
+7 SET AA=$ORDER(^PSX(552.4,"E",RXNDX,0))
SET BB=$ORDER(^PSX(552.4,"E",RXNDX,AA,0))
+8 IF $EXTRACT(IOST)="C"
WRITE !,"ENTRY AA BB ",AA," ",BB
+9 IF AA
IF BB
IF 1
+10 IF '$TEST
SET PSXERR="QAC RX Entry Not Found "_RXNDX_" "_FNAME
DO ERRMSG
QUIT
+11 SET SS="1"_$PIECE(MSG,"-")
SET PDT=PSXPDT
+12 KILL DIC,DA,DR,DIE,DO,DD
+13 if TYP="CA"
DO DODRX^PSXVEND
+14 if TYP="CR"
DO DODINV^PSXVEND
+15 QUIT
PIECE(REC,DLM,XX) ;
+1 ; Set variable V = piece P of REC using delimiter DLM
+2 NEW V,P
SET V=$PIECE(XX,U)
SET P=$PIECE(XX,U,2)
SET @V=$PIECE(REC,DLM,P)
+3 QUIT
PUT(REC,DLM,XX) ;
+1 ; Set Variable V into piece P of REC using delimiter DLM
+2 NEW V,P
SET V=$PIECE(XX,U)
SET P=$PIECE(XX,U,2)
+3 SET $PIECE(REC,DLM,P)=$GET(@V)
+4 QUIT
ERRMSG ;send error message to folks & DOD
+1 SET DIRHOLD=$$GET1^DIQ(554,1,23)
SET HOLD=$GET(HOLD)+1
+2 IF HOLD=1
Begin DoDot:1
+3 FOR XX=1:1:5
SET Y=$$GTF^%ZISH($NAME(^TMP($JOB,"PSXDOD",1)),3,DIRHOLD,FNAME)
if Y=1
QUIT
HANG 4
+4 IF Y'=1
SET GBL=$NAME(^TMP($JOB,"PSXDOD"))
DO FALERT^PSXDODNT(FNAME,DIRHOLD,GBL)
End DoDot:1
+5 SET XMSUB="DOD CMOP Error "_FNAME
+6 ;S XMY(DUZ)="" ;***TESTING
+7 SET XMY("G.PSXX CMOP MANAGERS")=""
+8 SET XMTEXT="PSXTXT("
+9 SET PSXTXT(1,0)="DOD CMOP .QAC Facility Release Acknowledgement filing experienced an error"
+10 SET PSXTXT(2,0)=$GET(PSXERR)
+11 SET PSXTXT(3,0)="FILE: "_FNAME
+12 SET PSXTXT(4,0)="A copy of the file has been placed in the hold directory "_DIRHOLD
+13 DO ^XMD
+14 IF $EXTRACT(IOST)="C"
WRITE !
FOR I=1:1:4
WRITE !,PSXTXT(I,0)
IF I=4
HANG 3
+15 KILL PSXTXT,DIRHOLD
+16 QUIT
RXNDX ; backfill the RX multiple RXNDX field #40 of file 552.4
+1 SET ORDDA=0
FOR
SET ORDDA=$ORDER(^PSX(552.4,ORDDA))
if ORDDA'>0
QUIT
Begin DoDot:1
+2 SET SITE=$$GET1^DIQ(552.4,ORDDA,.01)
SET SITE=$PIECE(SITE,"-")
+3 SET RXDA=0
FOR
SET RXDA=$ORDER(^PSX(552.4,ORDDA,1,RXDA))
if RXDA'>0
QUIT
SET XX=^(RXDA,0)
Begin DoDot:2
+4 FOR YY="RXNM^1","FILL^12"
DO PIECE(XX,U,YY)
+5 SET FILL=FILL+1
SET VAL=SITE_"-"_RXNM_"-"_FILL
+6 KILL DR,DIE,DA
+7 SET DIE="^PSX(552.4,"_ORDDA_",1,"
SET DA(1)=ORDDA
SET DA=RXDA
SET DR="40///^S X=VAL"
+8 DO ^DIE
KILL DR,DIE,DA
End DoDot:2
End DoDot:1
+9 QUIT
