- ECEDU ;BIR/MAM,JPW-Enter Event Capture Data (cont'd) ;6 Mar 96
- ;;2.0; EVENT CAPTURE ;**10,18,23,47,63,72**;8 May 96
- HDR ;hdr for filing
- W @IOF,!,"ENTERING A NEW PROCEDURE FOR "_ECPAT_" ...",!!,"LOCATION: "_ECLN,!,"SERVICE: "_ECSN,!,"SECTION: "_ECMN,!,"CATEGORY: "_ECCN,!!,"PROCEDURE: "
- W $S(ECCPT="":"",1:ECPTCD_" ")_$E(ECPN,1,50)
- I SYN]"",SYN'["NOT DEFINED" W " ["_SYN_"]"
- W " (#"_NATN_")"
- Q
- MSGC ;msg cat
- W !!,"Please enter the number that corresponds to the "_$S(EC1:"procedure",1:"category")_" from which",!,"you would like to select a procedure. If you would like to continue",!,"with the list, press <RET>. Enter ^ to quit."
- S CNT=CNT-5
- Q
- HDR1 ; heading
- W @IOF,!,"Patient: "_ECPAT,?40,"Procedure Date: "_ECDATE,!!,"Location: "_ECLN,?40,"Service: "_ECSN,!,"Section: "_ECMN,?40,"DSS Unit: "_ECDN W:$D(ECCN) !,"Category: "_ECCN
- Q
- MSG W !!,"No procedures entered. No Action Taken.",!!,"Press <RET> to continue " R X:DTIME S ECOUT=1
- Q
- SETE ;set edit
- N ECPXD
- S DA=+EC(EC),EC(0)=^ECH(DA,0),ECC=+$P(EC(0),"^",8),ECCN=$S('ECC:"None",$P($G(^EC(726,ECC,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- S (ECP,ECPROF)=$P(EC(0),"^",9)
- S ECPSY=+$O(^ECJ("AP",+ECL,+ECD,ECC,+ECP,""))
- S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2)
- S ECFILE=$S(ECPROF["EC":725,ECPROF["ICPT":81,1:"UNKNOWN")
- I ECFILE="UNKNOWN" S ECPN="UNKNOWN"
- S ECCPT=$S(ECP["ICPT":+ECP,1:$P($G(^EC(725,+ECP,0)),U,5))
- S (ECPTCD,ECPXD)="" I ECCPT'="" D
- . S ECPXD=$$CPT^ICPTCOD(ECCPT,$P(EC(0),U,3)) I +ECPXD>0 S ECPTCD=$P(ECPXD,U,2)
- I ECFILE=81 S ECPN=$S($P(ECPXD,U,3)]"":$P(ECPXD,U,3),1:"UNKNOWN")
- I ECFILE=725 S ECPN=$S($P($G(^EC(725,+ECP,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- HDRE ; hdr for editing
- W @IOF,!,"EDITING A PROCEDURE FOR "_ECPAT_" ...",!!,"LOCATION: "_ECLN,!,"SERVICE: "_ECSN,!,"SECTION: "_ECMN,!,"CATEGORY: "_ECCN,!,"PROCEDURE: "_$S(ECCPT="":"",1:ECPTCD_" ")_ECPN_$S(ECPSYN="":"",1:" ["_ECPSYN_"]")
- Q
- DXEDT ;ALB/JAM - Edit Primary and multiple secondary dx codes
- N PXUPD,IEN,ECPDX,ECDXS,ECDT,ECDXI
- S EC4=$P($G(^ECH(ECFN,0)),"^",19),(ECDX,ECDXN)="",ECDT=ECNEWDT
- S ECPDX=$$PDXCK^ECUTL2(ECDFN,ECNEWDT,ECL,EC4),IEN="" K ECDXIEN(ECFN)
- ;update primary diagnoses code
- S ECDX=ECDX1,ECDXI=$$ICDDX^ICDCODE(ECDX1,ECNEWDT),ECDXN=$P(ECDXI,U,2)
- W !,"Primary ICD-9 Code: ",ECDXN," ",$P(ECDXI,U,4)
- D PDX^ECUTL2 I ECOUT=1 Q
- S ECDX1=ECDX
- S DA=ECFN,DR="20////"_ECDX1 D ^DIE K DIE
- ;check for any changes to primary dx
- S ECDX1=X,IEN=""
- F S IEN=$O(ECDXIEN(IEN)) Q:IEN="" I $P(ECDXIEN(IEN),U,2)'=ECDX1 D Q
- .W !?5,"WARNING: More than 1 Primary diagnoses exist for this encounter. All"
- .W !?14,"Procedures will be updated to have same primary & secondary dx"
- ; update secondary diagnosis codes
- D SDX^ECUTL2 S DXS=""
- K ECDXX M ECDXX=ECDXS K ECDXS
- ;Update all procedures for the encounter with same primary dx
- S PXUPD=$$PXUPD^ECUTL2(ECDFN,ECNEWDT,ECL,EC4,ECDX1,.ECDXX)
- K PXUPD,ECDXX S DA=ECFN
- Q
- F S DXS=$O(ECDXS(DXS)) Q:DXS="" S DXSIEN=$P(ECDXS(DXS),U) D:DXSIEN>0
- . K DIC,DD,DO S DIC(0)="L",DA(1)=ECFN,DIC="^ECH("_DA(1)_","_"""DX"""_","
- . S DIC("P")=$P(^DD(721,38,0),U,2),X=DXSIEN D FILE^DICN
- K DXSIEN,DXS,ECDXX,DIC M ECDXX=ECDXS K ECDXS
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECEDU 3184 printed Jan 18, 2025@02:58:37 Page 2
- ECEDU ;BIR/MAM,JPW-Enter Event Capture Data (cont'd) ;6 Mar 96
- +1 ;;2.0; EVENT CAPTURE ;**10,18,23,47,63,72**;8 May 96
- HDR ;hdr for filing
- +1 WRITE @IOF,!,"ENTERING A NEW PROCEDURE FOR "_ECPAT_" ...",!!,"LOCATION: "_ECLN,!,"SERVICE: "_ECSN,!,"SECTION: "_ECMN,!,"CATEGORY: "_ECCN,!!,"PROCEDURE: "
- +2 WRITE $SELECT(ECCPT="":"",1:ECPTCD_" ")_$EXTRACT(ECPN,1,50)
- +3 IF SYN]""
- IF SYN'["NOT DEFINED"
- WRITE " ["_SYN_"]"
- +4 WRITE " (#"_NATN_")"
- +5 QUIT
- MSGC ;msg cat
- +1 WRITE !!,"Please enter the number that corresponds to the "_$SELECT(EC1:"procedure",1:"category")_" from which",!,"you would like to select a procedure. If you would like to continue",!,"with the list, press <RET>. Enter ^ to quit."
- +2 SET CNT=CNT-5
- +3 QUIT
- HDR1 ; heading
- +1 WRITE @IOF,!,"Patient: "_ECPAT,?40,"Procedure Date: "_ECDATE,!!,"Location: "_ECLN,?40,"Service: "_ECSN,!,"Section: "_ECMN,?40,"DSS Unit: "_ECDN
- if $DATA(ECCN)
- WRITE !,"Category: "_ECCN
- +2 QUIT
- MSG WRITE !!,"No procedures entered. No Action Taken.",!!,"Press <RET> to continue "
- READ X:DTIME
- SET ECOUT=1
- +1 QUIT
- SETE ;set edit
- +1 NEW ECPXD
- +2 SET DA=+EC(EC)
- SET EC(0)=^ECH(DA,0)
- SET ECC=+$PIECE(EC(0),"^",8)
- SET ECCN=$SELECT('ECC:"None",$PIECE($GET(^EC(726,ECC,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- +3 SET (ECP,ECPROF)=$PIECE(EC(0),"^",9)
- +4 SET ECPSY=+$ORDER(^ECJ("AP",+ECL,+ECD,ECC,+ECP,""))
- +5 SET ECPSYN=$PIECE($GET(^ECJ(ECPSY,"PRO")),"^",2)
- +6 SET ECFILE=$SELECT(ECPROF["EC":725,ECPROF["ICPT":81,1:"UNKNOWN")
- +7 IF ECFILE="UNKNOWN"
- SET ECPN="UNKNOWN"
- +8 SET ECCPT=$SELECT(ECP["ICPT":+ECP,1:$PIECE($GET(^EC(725,+ECP,0)),U,5))
- +9 SET (ECPTCD,ECPXD)=""
- IF ECCPT'=""
- Begin DoDot:1
- +10 SET ECPXD=$$CPT^ICPTCOD(ECCPT,$PIECE(EC(0),U,3))
- IF +ECPXD>0
- SET ECPTCD=$PIECE(ECPXD,U,2)
- End DoDot:1
- +11 IF ECFILE=81
- SET ECPN=$SELECT($PIECE(ECPXD,U,3)]"":$PIECE(ECPXD,U,3),1:"UNKNOWN")
- +12 IF ECFILE=725
- SET ECPN=$SELECT($PIECE($GET(^EC(725,+ECP,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- HDRE ; hdr for editing
- +1 WRITE @IOF,!,"EDITING A PROCEDURE FOR "_ECPAT_" ...",!!,"LOCATION: "_ECLN,!,"SERVICE: "_ECSN,!,"SECTION: "_ECMN,!,"CATEGORY: "_ECCN,!,"PROCEDURE: "_$SELECT(ECCPT="":"",1:ECPTCD_" ")_ECPN_$SELECT(ECPSYN="":"",1:" ["_ECPSYN_"]")
- +2 QUIT
- DXEDT ;ALB/JAM - Edit Primary and multiple secondary dx codes
- +1 NEW PXUPD,IEN,ECPDX,ECDXS,ECDT,ECDXI
- +2 SET EC4=$PIECE($GET(^ECH(ECFN,0)),"^",19)
- SET (ECDX,ECDXN)=""
- SET ECDT=ECNEWDT
- +3 SET ECPDX=$$PDXCK^ECUTL2(ECDFN,ECNEWDT,ECL,EC4)
- SET IEN=""
- KILL ECDXIEN(ECFN)
- +4 ;update primary diagnoses code
- +5 SET ECDX=ECDX1
- SET ECDXI=$$ICDDX^ICDCODE(ECDX1,ECNEWDT)
- SET ECDXN=$PIECE(ECDXI,U,2)
- +6 WRITE !,"Primary ICD-9 Code: ",ECDXN," ",$PIECE(ECDXI,U,4)
- +7 DO PDX^ECUTL2
- IF ECOUT=1
- QUIT
- +8 SET ECDX1=ECDX
- +9 SET DA=ECFN
- SET DR="20////"_ECDX1
- DO ^DIE
- KILL DIE
- +10 ;check for any changes to primary dx
- +11 SET ECDX1=X
- SET IEN=""
- +12 FOR
- SET IEN=$ORDER(ECDXIEN(IEN))
- if IEN=""
- QUIT
- IF $PIECE(ECDXIEN(IEN),U,2)'=ECDX1
- Begin DoDot:1
- +13 WRITE !?5,"WARNING: More than 1 Primary diagnoses exist for this encounter. All"
- +14 WRITE !?14,"Procedures will be updated to have same primary & secondary dx"
- End DoDot:1
- QUIT
- +15 ; update secondary diagnosis codes
- +16 DO SDX^ECUTL2
- SET DXS=""
- +17 KILL ECDXX
- MERGE ECDXX=ECDXS
- KILL ECDXS
- +18 ;Update all procedures for the encounter with same primary dx
- +19 SET PXUPD=$$PXUPD^ECUTL2(ECDFN,ECNEWDT,ECL,EC4,ECDX1,.ECDXX)
- +20 KILL PXUPD,ECDXX
- SET DA=ECFN
- +21 QUIT
- +22 FOR
- SET DXS=$ORDER(ECDXS(DXS))
- if DXS=""
- QUIT
- SET DXSIEN=$PIECE(ECDXS(DXS),U)
- if DXSIEN>0
- Begin DoDot:1
- +23 KILL DIC,DD,DO
- SET DIC(0)="L"
- SET DA(1)=ECFN
- SET DIC="^ECH("_DA(1)_","_"""DX"""_","
- +24 SET DIC("P")=$PIECE(^DD(721,38,0),U,2)
- SET X=DXSIEN
- DO FILE^DICN
- End DoDot:1
- +25 KILL DXSIEN,DXS,ECDXX,DIC
- MERGE ECDXX=ECDXS
- KILL ECDXS