- DGPTAE ;ALB/MTC,HIOFO/FT - Austin Edit Checks Driver ;4/8/15 11:23am
- ;;5.3;Registration;**58,415,884**;Aug 13, 1993;Build 31
- ;
- ; VALM APIs - #10118
- ;
- ; Check for 101, 501, 701; Route processing by type; call DRG and output routine
- EN ;
- N DGPTERP,DGPTERC,DGPRS,DGPTEDFL,DGPTNOW,DGPTFAC
- S (DGPTEDFL,DGPTERP)=0,DGPRS="N101^N501^N601^N701^N702^N703^N401^N402^N403^N535^"
- D NOW^%DTC S DGPTNOW=+X
- ;-- check if record available to process
- I '$D(^TMP("AEDIT")) G EXIT
- ;-- check if all nodes are present
- S DGPTERC=$$PRES() I DGPTERC D WRTERR(DGPTERC,"N101",1) G EXIT
- ;-- process record
- D ALLPR
- ;-- if errors
- D ERROR
- ;-- exit
- D EXIT
- Q
- ;
- ALLPR ;-- process all records types
- N ERROR,NODE,SEQ
- S ERROR=0
- ;
- D FAC
- ;
- S NODE="" F S NODE=$O(^TMP("AEDIT",$J,NODE)) Q:NODE=""!(ERROR) D
- . S SEQ=0 F S SEQ=$O(^TMP("AEDIT",$J,NODE,SEQ)) Q:SEQ="" D RTE
- ;
- Q
- ;
- EXIT ;-- clean-up
- K ^TMP("AEDIT",$J),^TMP("AERROR",$J),^TMP("AD",$J)
- K DGPTDTS,DGPTPS,DGPTSSN,DGPTDTA,DGPTFAC,DGPTLN,DGPTFI,DGPTMI
- K DGPTSRA,DGPTTF,DGPTSRP,DGPTPOW,DGPTMRS,DGPTGEN,DGPTDOB,DGPTPOS1,DGPTPOS2,DGPTEXA,DGPTEXI,DGPTSTE,DGPTCTY,DGPTZIP,DGPTMTC,DGPTBY,DGPTINC
- K DGPTDDTD,DGPTDDS,DGPTDSP,DGPTDTY,DGPTDOP,DGPTDVA,DGPTDPD,DGPTDRF,DGPTDAS,DGPTDCP,DGPTDDXE,DGPTDDXO,DGPTDLR,DGPTDLC,DGPTDSC
- K DGPT70LG,DGPT70SU,DGPT70DR,DGPT70X4,DGPTDXV1,DGPTDXV2,DGPT70AO,DGPT70COMVET,DGPT70ETHNIC,DGPT70HNC,DGPT70IR,DGPT70MST,DGPTTOD,DGPTDOD
- K DGPTMSR,DGPTMSC,DGPTMLD,DGPTMPD,DGPTMSI,DGPTMD1,DGPTMD11,DGPTMD2,DGPTMD3,DGPTMD4,DGPTMD5,DGPTMXX,DGPTMLR,DGPTMLC,DGPTMBS
- K DGPTMLG,DGPTMSU,DGPTMDG,DGPTMXIV,DGPTMXV1,DGPTMXV2,DGPT50SR,DGPT70RACE,DGPT70RACE1,DGPT70RACE2,DGPT70RACE3,DGPT70RACE4,DGPT70RACE5,DGPT70RACE6
- K DGACNT,DGPT7X51,DGPT7X52,DGPTADT,DGPTAGE,DGPTAL7,DGPTBYR,DGPTDIA,DGPTDIA1,DGPTDIA2,DGPTDIAR,DGPTELP,DGPTFEF,DGPTFMDB,DGPTGEN1,DGPTL3,DGPTL4,DGPTMSX,DGPTS1,DGPTS2,DGPTSTTY,DGPTTY,DGPTXTTY,DGSCDT,DGPTPRAR,DGPTOPAR,DGSCDT,DGPTOC
- K DGFNUM,DGLAST,DGMVT,DGOUT,DGPTF,DGPTOPP,DGSCDT,DGSPEC,DGLAST,DGFNUM,DGPT70SHAD,DGPT70SWA,DGPT70TSC,DGPTOD,DGPTDXLSPOA,DGPTGD1
- K DGPTMPOA1,DGPTMPOA10,DGPTMPOA11,DGPTMPOA12,DGPTMPOA13,DGPTMPOA14,DGPTMPOA15,DGPTMPOA16,DGPTMPOA17,DGPTMPOA18,DGPTMPOA19,DGPTMPOA2
- K DGPTMPOA20,DGPTMPOA21,DGPTMPOA22,DGPTMPOA23,DGPTMPOA24,DGPTMPOA25,DGPTMPOA3,DGPTMPOA4,DGPTMPOA5,DGPTMPOA6,DGPTMPOA7,DGPTMPOA8,DGPTMPOA9
- Q
- ;
- RTE ;route processing
- N DGFL2,I,J
- S DGFL2=0 F I=1:1:10 S:NODE=$P(DGPRS,U,I) DGFL2=1 Q:(DGFL2)!($P(DGPRS,U,I)']"")
- I 'DGFL2 S ERROR=101 Q
- Q:NODE="N701"
- ;
- D @("^DGPT"_$S($E(NODE,2)=4:"401",1:$E(NODE,2,4)))
- RTN ;
- Q
- ;
- PRES() ;-- check if required pieces are present
- N I,ERROR
- S ERROR=0
- F I="N101","N501","N701" I '$D(^TMP("AEDIT",$J,I)) S ERROR=188 Q
- Q ERROR
- ;
- WRTERR(ERROR,NODE,SEQ) ;-- This function will write out errors to the ^TMP("AERROR"
- ; global.
- ; INPUT : ERROR - code of Austin's error
- ; NODE - node error occurred on
- ; SEQ - sequence in ^TMP("AEDIT",
- ;
- I '$D(ERROR) G WRTQ
- S DGPTERP=DGPTERP+1,^TMP("AERROR",$J,SEQ,NODE,DGPTERP)=ERROR
- I DGPTERP>12 S DGPTEDFL=1
- WRTQ Q
- ;
- FAC ;-- check facility id; get station type
- N SUFFIX,SOA,STATION,STTY
- S DGPTSTTY="",X=$G(^TMP("AEDIT",$J,"N101",1)),DGPTFAC=$E(X,25,30),SUFFIX=$E(X,29,30),SOA=$E(X,45,46)
- I SOA=" " D WRTERR(107) G FACQ
- I DGPTFAC'=" ",'DGPTFAC D WRTERR(108,"101") G FACQ
- I SUFFIX]"" I $D(^DIC(45.81,"D1",SUFFIX)) S DGPTSTTY=$O(^(SUFFIX,0)) S:DGPTSTTY DGPTSTTY=U_DGPTSTTY_U
- S X=$O(^DIC(45.1,"B",$E(X,45,46),0))
- S STATION="",STTY=0 F S STTY=$O(^DIC(45.1,X,"ST",STTY)) Q:'STTY S STATION=STATION_"^"_STTY
- S STATION=STATION_"^"
- I $P(DGPTSTTY,U,2),STATION'[DGPTSTTY D WRTERR(135,"101") G FACQ
- S DGPTSTTY=STATION
- FACQ Q
- ;
- ERROR ;-- this routine will process the error detected during close-out
- G:'$D(^TMP("AERROR",$J)) ERRQ
- S DGERR=1
- D EN^VALM("DGPT CLOSE-OUT ERROR")
- ERRQ Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTAE 3900 printed Jan 18, 2025@03:52:10 Page 2
- DGPTAE ;ALB/MTC,HIOFO/FT - Austin Edit Checks Driver ;4/8/15 11:23am
- +1 ;;5.3;Registration;**58,415,884**;Aug 13, 1993;Build 31
- +2 ;
- +3 ; VALM APIs - #10118
- +4 ;
- +5 ; Check for 101, 501, 701; Route processing by type; call DRG and output routine
- EN ;
- +1 NEW DGPTERP,DGPTERC,DGPRS,DGPTEDFL,DGPTNOW,DGPTFAC
- +2 SET (DGPTEDFL,DGPTERP)=0
- SET DGPRS="N101^N501^N601^N701^N702^N703^N401^N402^N403^N535^"
- +3 DO NOW^%DTC
- SET DGPTNOW=+X
- +4 ;-- check if record available to process
- +5 IF '$DATA(^TMP("AEDIT"))
- GOTO EXIT
- +6 ;-- check if all nodes are present
- +7 SET DGPTERC=$$PRES()
- IF DGPTERC
- DO WRTERR(DGPTERC,"N101",1)
- GOTO EXIT
- +8 ;-- process record
- +9 DO ALLPR
- +10 ;-- if errors
- +11 DO ERROR
- +12 ;-- exit
- +13 DO EXIT
- +14 QUIT
- +15 ;
- ALLPR ;-- process all records types
- +1 NEW ERROR,NODE,SEQ
- +2 SET ERROR=0
- +3 ;
- +4 DO FAC
- +5 ;
- +6 SET NODE=""
- FOR
- SET NODE=$ORDER(^TMP("AEDIT",$JOB,NODE))
- if NODE=""!(ERROR)
- QUIT
- Begin DoDot:1
- +7 SET SEQ=0
- FOR
- SET SEQ=$ORDER(^TMP("AEDIT",$JOB,NODE,SEQ))
- if SEQ=""
- QUIT
- DO RTE
- End DoDot:1
- +8 ;
- +9 QUIT
- +10 ;
- EXIT ;-- clean-up
- +1 KILL ^TMP("AEDIT",$JOB),^TMP("AERROR",$JOB),^TMP("AD",$JOB)
- +2 KILL DGPTDTS,DGPTPS,DGPTSSN,DGPTDTA,DGPTFAC,DGPTLN,DGPTFI,DGPTMI
- +3 KILL DGPTSRA,DGPTTF,DGPTSRP,DGPTPOW,DGPTMRS,DGPTGEN,DGPTDOB,DGPTPOS1,DGPTPOS2,DGPTEXA,DGPTEXI,DGPTSTE,DGPTCTY,DGPTZIP,DGPTMTC,DGPTBY,DGPTINC
- +4 KILL DGPTDDTD,DGPTDDS,DGPTDSP,DGPTDTY,DGPTDOP,DGPTDVA,DGPTDPD,DGPTDRF,DGPTDAS,DGPTDCP,DGPTDDXE,DGPTDDXO,DGPTDLR,DGPTDLC,DGPTDSC
- +5 KILL DGPT70LG,DGPT70SU,DGPT70DR,DGPT70X4,DGPTDXV1,DGPTDXV2,DGPT70AO,DGPT70COMVET,DGPT70ETHNIC,DGPT70HNC,DGPT70IR,DGPT70MST,DGPTTOD,DGPTDOD
- +6 KILL DGPTMSR,DGPTMSC,DGPTMLD,DGPTMPD,DGPTMSI,DGPTMD1,DGPTMD11,DGPTMD2,DGPTMD3,DGPTMD4,DGPTMD5,DGPTMXX,DGPTMLR,DGPTMLC,DGPTMBS
- +7 KILL DGPTMLG,DGPTMSU,DGPTMDG,DGPTMXIV,DGPTMXV1,DGPTMXV2,DGPT50SR,DGPT70RACE,DGPT70RACE1,DGPT70RACE2,DGPT70RACE3,DGPT70RACE4,DGPT70RACE5,DGPT70RACE6
- +8 KILL DGACNT,DGPT7X51,DGPT7X52,DGPTADT,DGPTAGE,DGPTAL7,DGPTBYR,DGPTDIA,DGPTDIA1,DGPTDIA2,DGPTDIAR,DGPTELP,DGPTFEF,DGPTFMDB,DGPTGEN1,DGPTL3,DGPTL4,DGPTMSX,DGPTS1,DGPTS2,DGPTSTTY,DGPTTY,DGPTXTTY,DGSCDT,DGPTPRAR,DGPTOPAR,DGSCDT,DGPTOC
- +9 KILL DGFNUM,DGLAST,DGMVT,DGOUT,DGPTF,DGPTOPP,DGSCDT,DGSPEC,DGLAST,DGFNUM,DGPT70SHAD,DGPT70SWA,DGPT70TSC,DGPTOD,DGPTDXLSPOA,DGPTGD1
- +10 KILL DGPTMPOA1,DGPTMPOA10,DGPTMPOA11,DGPTMPOA12,DGPTMPOA13,DGPTMPOA14,DGPTMPOA15,DGPTMPOA16,DGPTMPOA17,DGPTMPOA18,DGPTMPOA19,DGPTMPOA2
- +11 KILL DGPTMPOA20,DGPTMPOA21,DGPTMPOA22,DGPTMPOA23,DGPTMPOA24,DGPTMPOA25,DGPTMPOA3,DGPTMPOA4,DGPTMPOA5,DGPTMPOA6,DGPTMPOA7,DGPTMPOA8,DGPTMPOA9
- +12 QUIT
- +13 ;
- RTE ;route processing
- +1 NEW DGFL2,I,J
- +2 SET DGFL2=0
- FOR I=1:1:10
- if NODE=$PIECE(DGPRS,U,I)
- SET DGFL2=1
- if (DGFL2)!($PIECE(DGPRS,U,I)']"")
- QUIT
- +3 IF 'DGFL2
- SET ERROR=101
- QUIT
- +4 if NODE="N701"
- QUIT
- +5 ;
- +6 DO @("^DGPT"_$SELECT($EXTRACT(NODE,2)=4:"401",1:$EXTRACT(NODE,2,4)))
- RTN ;
- +1 QUIT
- +2 ;
- PRES() ;-- check if required pieces are present
- +1 NEW I,ERROR
- +2 SET ERROR=0
- +3 FOR I="N101","N501","N701"
- IF '$DATA(^TMP("AEDIT",$JOB,I))
- SET ERROR=188
- QUIT
- +4 QUIT ERROR
- +5 ;
- WRTERR(ERROR,NODE,SEQ) ;-- This function will write out errors to the ^TMP("AERROR"
- +1 ; global.
- +2 ; INPUT : ERROR - code of Austin's error
- +3 ; NODE - node error occurred on
- +4 ; SEQ - sequence in ^TMP("AEDIT",
- +5 ;
- +6 IF '$DATA(ERROR)
- GOTO WRTQ
- +7 SET DGPTERP=DGPTERP+1
- SET ^TMP("AERROR",$JOB,SEQ,NODE,DGPTERP)=ERROR
- +8 IF DGPTERP>12
- SET DGPTEDFL=1
- WRTQ QUIT
- +1 ;
- FAC ;-- check facility id; get station type
- +1 NEW SUFFIX,SOA,STATION,STTY
- +2 SET DGPTSTTY=""
- SET X=$GET(^TMP("AEDIT",$JOB,"N101",1))
- SET DGPTFAC=$EXTRACT(X,25,30)
- SET SUFFIX=$EXTRACT(X,29,30)
- SET SOA=$EXTRACT(X,45,46)
- +3 IF SOA=" "
- DO WRTERR(107)
- GOTO FACQ
- +4 IF DGPTFAC'=" "
- IF 'DGPTFAC
- DO WRTERR(108,"101")
- GOTO FACQ
- +5 IF SUFFIX]""
- IF $DATA(^DIC(45.81,"D1",SUFFIX))
- SET DGPTSTTY=$ORDER(^(SUFFIX,0))
- if DGPTSTTY
- SET DGPTSTTY=U_DGPTSTTY_U
- +6 SET X=$ORDER(^DIC(45.1,"B",$EXTRACT(X,45,46),0))
- +7 SET STATION=""
- SET STTY=0
- FOR
- SET STTY=$ORDER(^DIC(45.1,X,"ST",STTY))
- if 'STTY
- QUIT
- SET STATION=STATION_"^"_STTY
- +8 SET STATION=STATION_"^"
- +9 IF $PIECE(DGPTSTTY,U,2)
- IF STATION'[DGPTSTTY
- DO WRTERR(135,"101")
- GOTO FACQ
- +10 SET DGPTSTTY=STATION
- FACQ QUIT
- +1 ;
- ERROR ;-- this routine will process the error detected during close-out
- +1 if '$DATA(^TMP("AERROR",$JOB))
- GOTO ERRQ
- +2 SET DGERR=1
- +3 DO EN^VALM("DGPT CLOSE-OUT ERROR")
- ERRQ QUIT
- +1 ;