- 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 Mar 13, 2025@20:48:39 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
