- ECHECK1 ;BIR/MAM,JPW-Categories and Procedures Check ;1/26/16 15:59
- ;;2.0;EVENT CAPTURE ;**4,33,47,55,63,126,131**;8 May 96;Build 13
- CATS ; check number of categories
- K ECBUD,EC1,EC23 S CNT=0,ECAT=""
- I $P(^ECD(ECD,0),U,11) F S ECAT=$O(^ECJ("AP",ECL,ECD,ECAT)) Q:ECAT="" D ;131 Only list categories if unit allows categories
- .S EC2="" F S EC2=$O(^ECJ("AP",ECL,ECD,ECAT,EC2)) Q:EC2="" D
- ..S EC23=+$O(^ECJ("AP",ECL,ECD,ECAT,EC2,0))
- ..I $G(ECCSTA)="",$P($G(^ECJ(+EC23,0)),"^",2) Q
- ..S ECBUD(ECAT)=+ECAT_"^"_$S($P($G(^EC(726,+ECAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- S ECAT=0 F S ECAT=$O(ECBUD(ECAT)) Q:'ECAT S CNT=CNT+1,ECC(CNT)=ECBUD(ECAT)
- I '$D(ECC) S ECC(CNT)="0^No Categories"
- K EC2,EC23,ECBUD
- Q
- PROS ; check number of procedures
- K ^TMP("ECPRO",$J) S CNT=0,ECPROS=""
- I ECC F S ECPROS=$O(^ECJ("AP",ECL,ECD,ECC,ECPROS)) Q:ECPROS="" D SET
- I 'ECC S ECC="" F S ECC=$O(^ECJ("AP",ECL,ECD,ECC)) Q:ECC="" F S ECPROS=$O(^ECJ("AP",ECL,ECD,ECC,ECPROS)) Q:ECPROS="" D SET
- ALL ;set info for all proc
- S CNT=0 F CNT=0:0 S CNT=$O(^TMP("ECPRO",$J,CNT)) Q:'CNT D
- .S ECPROF=$P(^TMP("ECPRO",$J,CNT),"^"),ECPIEN=$P(^(CNT),"^",2),ECPROPP=+ECPROF,ECPROF=$S(ECPROF["EC":725,ECPROF["ICPT":81,1:"UNKNOWN"),OK=0
- .I ECPROF=725 S NODE1=$G(^EC(725,ECPROPP,0)),ECPRONAM=$S($P($G(NODE1),"^")]"":$P(NODE1,"^"),1:"UNKNOWN"),NATN=$P(NODE1,"^",2),OK=1
- .I ECPROF=81 S NODE1=$$CPT^ICPTCOD(ECPROPP,$G(ECDT)),ECPRONAM=$S($P($G(NODE1),"^",3)]"":$P(NODE1,"^",3),1:"UNKNOWN"),NATN=$S($P(NODE1,"^",2)]"":$P(NODE1,"^",2),1:"NOT DEFINED"),OK=1
- .S:'OK ECPRONAM="UNKNOWN"
- .S NODE1=$G(^ECJ(ECPIEN,0)),ECTEMP=$P(NODE1,"^",2)
- .;The ECACTIV variable allows users to select inactivate
- .;procedures from the Inactivate Event Code Screen option.
- .I '$G(ECACTIV) I ECTEMP,ECTEMP'>DT K ECPIEN,ECPROF,ECPROPP,ECPRONAM,ECTEMP,NODE1,NOD2,SYN,NATN,VOL Q
- .S NODE2=$G(^ECJ(ECPIEN,"PRO")),SYN=$S($P(NODE2,"^",2)]"":$P(NODE2,"^",2),1:"NOT DEFINED"),VOL=$P(NODE2,"^",3)
- .S ^TMP("ECPRO",$J,CNT)=^TMP("ECPRO",$J,CNT)_"^"_SYN_"^"_ECPRONAM_"^"_NATN_"^"_VOL_"^"_ECPROF_"^"_ECPROPP_"^"_ECTEMP
- .S ^TMP("ECPRO",$J,"B",ECPRONAM,CNT)="",^TMP("ECPRO",$J,"SYN",SYN,CNT)="",^TMP("ECPRO",$J,"N",NATN,CNT)="",^TMP("ECPRO",$J,"N2",NATN_" ",CNT)="" ;126 N2 is expected sort order
- K ECPIEN,ECPROF,ECPROPP,ECPRONAM,ECTEMP,NODE1,NODE2,SYN,NATN,VOL
- Q
- SET ;set proc in ^tmp
- S ECPIEN=$O(^ECJ("AP",ECL,ECD,ECC,ECPROS,0))
- ;The ECACTIV variable allows users to select inactive.
- ;procedures from the Inactivate Event Code Screen option.
- I '$G(ECACTIV) I $P($G(^ECJ(ECPIEN,0)),"^",2),$P($G(^ECJ(ECPIEN,0)),"^",2)'>DT Q
- ;remove inactive procedures
- S NODE1=$S(ECPROS[";ICPT(":+ECPROS,1:$P($G(^EC(725,+ECPROS,0)),U,5))
- ; ATG-1003-32110 : By VMP
- I NODE1'="" S NODE1=$$CPT^ICPTCOD(NODE1,$G(ECDT)) Q:+NODE1<0 I '$P(NODE1,U,7),'$G(ECACTIV) Q
- S CNT=CNT+1
- S ^TMP("ECPRO",$J,CNT)=ECPROS_"^"_ECPIEN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECHECK1 2898 printed Jan 18, 2025@02:58:41 Page 2
- ECHECK1 ;BIR/MAM,JPW-Categories and Procedures Check ;1/26/16 15:59
- +1 ;;2.0;EVENT CAPTURE ;**4,33,47,55,63,126,131**;8 May 96;Build 13
- CATS ; check number of categories
- +1 KILL ECBUD,EC1,EC23
- SET CNT=0
- SET ECAT=""
- +2 ;131 Only list categories if unit allows categories
- IF $PIECE(^ECD(ECD,0),U,11)
- FOR
- SET ECAT=$ORDER(^ECJ("AP",ECL,ECD,ECAT))
- if ECAT=""
- QUIT
- Begin DoDot:1
- +3 SET EC2=""
- FOR
- SET EC2=$ORDER(^ECJ("AP",ECL,ECD,ECAT,EC2))
- if EC2=""
- QUIT
- Begin DoDot:2
- +4 SET EC23=+$ORDER(^ECJ("AP",ECL,ECD,ECAT,EC2,0))
- +5 IF $GET(ECCSTA)=""
- IF $PIECE($GET(^ECJ(+EC23,0)),"^",2)
- QUIT
- +6 SET ECBUD(ECAT)=+ECAT_"^"_$SELECT($PIECE($GET(^EC(726,+ECAT,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- End DoDot:2
- End DoDot:1
- +7 SET ECAT=0
- FOR
- SET ECAT=$ORDER(ECBUD(ECAT))
- if 'ECAT
- QUIT
- SET CNT=CNT+1
- SET ECC(CNT)=ECBUD(ECAT)
- +8 IF '$DATA(ECC)
- SET ECC(CNT)="0^No Categories"
- +9 KILL EC2,EC23,ECBUD
- +10 QUIT
- PROS ; check number of procedures
- +1 KILL ^TMP("ECPRO",$JOB)
- SET CNT=0
- SET ECPROS=""
- +2 IF ECC
- FOR
- SET ECPROS=$ORDER(^ECJ("AP",ECL,ECD,ECC,ECPROS))
- if ECPROS=""
- QUIT
- DO SET
- +3 IF 'ECC
- SET ECC=""
- FOR
- SET ECC=$ORDER(^ECJ("AP",ECL,ECD,ECC))
- if ECC=""
- QUIT
- FOR
- SET ECPROS=$ORDER(^ECJ("AP",ECL,ECD,ECC,ECPROS))
- if ECPROS=""
- QUIT
- DO SET
- ALL ;set info for all proc
- +1 SET CNT=0
- FOR CNT=0:0
- SET CNT=$ORDER(^TMP("ECPRO",$JOB,CNT))
- if 'CNT
- QUIT
- Begin DoDot:1
- +2 SET ECPROF=$PIECE(^TMP("ECPRO",$JOB,CNT),"^")
- SET ECPIEN=$PIECE(^(CNT),"^",2)
- SET ECPROPP=+ECPROF
- SET ECPROF=$SELECT(ECPROF["EC":725,ECPROF["ICPT":81,1:"UNKNOWN")
- SET OK=0
- +3 IF ECPROF=725
- SET NODE1=$GET(^EC(725,ECPROPP,0))
- SET ECPRONAM=$SELECT($PIECE($GET(NODE1),"^")]"":$PIECE(NODE1,"^"),1:"UNKNOWN")
- SET NATN=$PIECE(NODE1,"^",2)
- SET OK=1
- +4 IF ECPROF=81
- SET NODE1=$$CPT^ICPTCOD(ECPROPP,$GET(ECDT))
- SET ECPRONAM=$SELECT($PIECE($GET(NODE1),"^",3)]"":$PIECE(NODE1,"^",3),1:"UNKNOWN")
- SET NATN=$SELECT($PIECE(NODE1,"^",2)]"":$PIECE(NODE1,"^",2),1:"NOT DEFINED")
- SET OK=1
- +5 if 'OK
- SET ECPRONAM="UNKNOWN"
- +6 SET NODE1=$GET(^ECJ(ECPIEN,0))
- SET ECTEMP=$PIECE(NODE1,"^",2)
- +7 ;The ECACTIV variable allows users to select inactivate
- +8 ;procedures from the Inactivate Event Code Screen option.
- +9 IF '$GET(ECACTIV)
- IF ECTEMP
- IF ECTEMP'>DT
- KILL ECPIEN,ECPROF,ECPROPP,ECPRONAM,ECTEMP,NODE1,NOD2,SYN,NATN,VOL
- QUIT
- +10 SET NODE2=$GET(^ECJ(ECPIEN,"PRO"))
- SET SYN=$SELECT($PIECE(NODE2,"^",2)]"":$PIECE(NODE2,"^",2),1:"NOT DEFINED")
- SET VOL=$PIECE(NODE2,"^",3)
- +11 SET ^TMP("ECPRO",$JOB,CNT)=^TMP("ECPRO",$JOB,CNT)_"^"_SYN_"^"_ECPRONAM_"^"_NATN_"^"_VOL_"^"_ECPROF_"^"_ECPROPP_"^"_ECTEMP
- +12 ;126 N2 is expected sort order
- SET ^TMP("ECPRO",$JOB,"B",ECPRONAM,CNT)=""
- SET ^TMP("ECPRO",$JOB,"SYN",SYN,CNT)=""
- SET ^TMP("ECPRO",$JOB,"N",NATN,CNT)=""
- SET ^TMP("ECPRO",$JOB,"N2",NATN_" ",CNT)=""
- End DoDot:1
- +13 KILL ECPIEN,ECPROF,ECPROPP,ECPRONAM,ECTEMP,NODE1,NODE2,SYN,NATN,VOL
- +14 QUIT
- SET ;set proc in ^tmp
- +1 SET ECPIEN=$ORDER(^ECJ("AP",ECL,ECD,ECC,ECPROS,0))
- +2 ;The ECACTIV variable allows users to select inactive.
- +3 ;procedures from the Inactivate Event Code Screen option.
- +4 IF '$GET(ECACTIV)
- IF $PIECE($GET(^ECJ(ECPIEN,0)),"^",2)
- IF $PIECE($GET(^ECJ(ECPIEN,0)),"^",2)'>DT
- QUIT
- +5 ;remove inactive procedures
- +6 SET NODE1=$SELECT(ECPROS[";ICPT(":+ECPROS,1:$PIECE($GET(^EC(725,+ECPROS,0)),U,5))
- +7 ; ATG-1003-32110 : By VMP
- +8 IF NODE1'=""
- SET NODE1=$$CPT^ICPTCOD(NODE1,$GET(ECDT))
- if +NODE1<0
- QUIT
- IF '$PIECE(NODE1,U,7)
- IF '$GET(ECACTIV)
- QUIT
- +9 SET CNT=CNT+1
- +10 SET ^TMP("ECPRO",$JOB,CNT)=ECPROS_"^"_ECPIEN
- +11 QUIT