- ECBEPF ;BIR/MAM,JPW-Stuff Batch Entry by Procedure (cont'd) ;2 Mar 96
- ;;2.0; EVENT CAPTURE ;**4,5,13,17,18,23,42,54,72,76**;8 May 96;Build 6
- CRAM ; entry
- S ECDT=$P(ECA,"^"),ECL=$P(ECA,"^",2),ECS=$P(ECA,"^",3),ECM=$P(ECA,"^",4),ECD=$P(ECA,"^",5)
- S ECPCE=$P(ECA,"^",6)
- S (CNT,CNT1)=0 F S CNT1=$O(ECPT(CNT1)) Q:'CNT1 D SET F S CNT=$O(ECEC(CNT)) Q:'CNT D DIE
- END D ^ECKILL K DLAYGO S:$D(ZTQUEUED) ZTREQ="@"
- Q
- SET ;
- S ECPS=$P(ECPT(CNT1),"^"),ECO=$P(ECPT(CNT1),"^",3),ECV=+$P(ECPT(CNT1),"^",5)
- S ECDX=$P(ECPT(CNT1),"^",6),ECINP=$P(ECPT(CNT1),"^",7),ECVST=$P(ECPT(CNT1),"^",8),ECSC=$P(ECPT(CNT1),"^",9),ECAO=$P(ECPT(CNT1),"^",10),ECIR=$P(ECPT(CNT1),"^",11)
- S ECZEC=$P(ECPT(CNT1),"^",12),EC4=$P(ECPT(CNT1),"^",13),ECID=$P(ECPT(CNT1),"^",14)
- S ECMST=$P(ECPT(CNT1),"^",15),ECHNC=$P(ECPT(CNT1),"^",16),ECCV=$P(ECPT(CNT1),"^",17),ECSHAD=$P(ECPT(CNT1),"^",18)
- S ECELIG=$G(ECELPT(CNT1))
- Q
- DIE ;
- L +^ECH(0):60 S ECRN=$P(^ECH(0),"^",3)+1 I $D(^ECH(ECRN)) S $P(^ECH(0),"^",3)=$P(^ECH(0),"^",3)+1 L -^ECH(0) G DIE
- L -^ECH(0) K DD,DO,DIC S X=ECRN,DIC(0)="L",DLAYGO=721,DIC="^ECH(" D FILE^DICN K DIC S ECFN=+Y
- S ECNODE=ECEC(CNT),ECC=+$P(ECNODE,"^"),ECP=$P(ECNODE,"^",2),ECPRPTR=$P(ECNODE,"^",12)
- S ECCPT=$P(ECNODE,"^",9)
- ; set the zero node
- S ^ECH(ECFN,0)=ECFN_"^"_ECPS_"^"_ECDT_"^"_ECL_"^"_ECS_"^"_ECM_"^"_ECD_"^"_ECC_"^"_ECP_"^"_ECV_"^^"_ECO_"^"_ECDUZ_"^^^^^^"_EC4_"^"_ECID_"^"_ECVST_"^"_ECINP
- ;ALB/JAM file multiple providers (EC*2*72)
- S ECFIL=$$FILPRV^ECPRVMUT(ECFN,.ECPRVARY,.ECOUT) K ECFIL
- ;ALB/ESD - Set procedure reason into zero node
- I +ECPRPTR S $P(^ECH(ECFN,0),"^",23)=+ECPRPTR
- ;set the "P" node
- S ^ECH(ECFN,"P")=ECCPT_"^"_ECDX_"^"_ECAO_"^"_ECIR_"^"_ECZEC_"^"_ECSC
- S $P(^ECH(ECFN,"P"),"^",9,12)=ECMST_"^"_ECHNC_"^"_ECCV_"^"_ECSHAD
- ;add secondary diagnosis codes
- I $O(ECPT(CNT1,"DXS",""))'="" D K DXSIEN,DXS
- . S DXS="" F S DXS=$O(ECPT(CNT1,"DXS",DXS)) Q:DXS="" D
- . . S DXSIEN=$P(ECPT(CNT1,"DXS",DXS),U) I DXSIEN<0 Q
- . . 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 ECDXX M ECDXX=ECPT(CNT1,"DXS")
- S PXUPD=$$PXUPD^ECUTL2(ECPS,ECDT,ECL,EC4,ECDX,.ECDXX,ECFN) K PXUPD,ECDXX
- ;add CPT procedure modifiers
- I $O(ECEC(CNT,"MOD",""))'="" D K MODIEN,MOD
- . S MOD="" F S MOD=$O(ECEC(CNT,"MOD",MOD)) Q:MOD="" D
- . . S MODIEN=$P(ECEC(CNT,"MOD",MOD),U,2) I MODIEN<0 Q
- . . K DIC,DD,DO
- . . S DIC(0)="L",DA(1)=ECFN,DIC="^ECH("_DA(1)_","_"""MOD"""_","
- . . S DIC("P")=$P(^DD(721,36,0),U,2),X=MODIEN
- . . D FILE^DICN
- XREF ; sets crossreferences
- S DIK="^ECH(",DA=ECFN D IX1^DIK K DA,DIK
- PCE ;format data to send PCE
- Q:$P(ECPCE,"~",2)="N" I $P(ECPCE,"~",2)="O"&(ECINP'="O") Q
- D PCE^ECBEN2U
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECBEPF 2759 printed Mar 13, 2025@21:01:40 Page 2
- ECBEPF ;BIR/MAM,JPW-Stuff Batch Entry by Procedure (cont'd) ;2 Mar 96
- +1 ;;2.0; EVENT CAPTURE ;**4,5,13,17,18,23,42,54,72,76**;8 May 96;Build 6
- CRAM ; entry
- +1 SET ECDT=$PIECE(ECA,"^")
- SET ECL=$PIECE(ECA,"^",2)
- SET ECS=$PIECE(ECA,"^",3)
- SET ECM=$PIECE(ECA,"^",4)
- SET ECD=$PIECE(ECA,"^",5)
- +2 SET ECPCE=$PIECE(ECA,"^",6)
- +3 SET (CNT,CNT1)=0
- FOR
- SET CNT1=$ORDER(ECPT(CNT1))
- if 'CNT1
- QUIT
- DO SET
- FOR
- SET CNT=$ORDER(ECEC(CNT))
- if 'CNT
- QUIT
- DO DIE
- END DO ^ECKILL
- KILL DLAYGO
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +1 QUIT
- SET ;
- +1 SET ECPS=$PIECE(ECPT(CNT1),"^")
- SET ECO=$PIECE(ECPT(CNT1),"^",3)
- SET ECV=+$PIECE(ECPT(CNT1),"^",5)
- +2 SET ECDX=$PIECE(ECPT(CNT1),"^",6)
- SET ECINP=$PIECE(ECPT(CNT1),"^",7)
- SET ECVST=$PIECE(ECPT(CNT1),"^",8)
- SET ECSC=$PIECE(ECPT(CNT1),"^",9)
- SET ECAO=$PIECE(ECPT(CNT1),"^",10)
- SET ECIR=$PIECE(ECPT(CNT1),"^",11)
- +3 SET ECZEC=$PIECE(ECPT(CNT1),"^",12)
- SET EC4=$PIECE(ECPT(CNT1),"^",13)
- SET ECID=$PIECE(ECPT(CNT1),"^",14)
- +4 SET ECMST=$PIECE(ECPT(CNT1),"^",15)
- SET ECHNC=$PIECE(ECPT(CNT1),"^",16)
- SET ECCV=$PIECE(ECPT(CNT1),"^",17)
- SET ECSHAD=$PIECE(ECPT(CNT1),"^",18)
- +5 SET ECELIG=$GET(ECELPT(CNT1))
- +6 QUIT
- DIE ;
- +1 LOCK +^ECH(0):60
- SET ECRN=$PIECE(^ECH(0),"^",3)+1
- IF $DATA(^ECH(ECRN))
- SET $PIECE(^ECH(0),"^",3)=$PIECE(^ECH(0),"^",3)+1
- LOCK -^ECH(0)
- GOTO DIE
- +2 LOCK -^ECH(0)
- KILL DD,DO,DIC
- SET X=ECRN
- SET DIC(0)="L"
- SET DLAYGO=721
- SET DIC="^ECH("
- DO FILE^DICN
- KILL DIC
- SET ECFN=+Y
- +3 SET ECNODE=ECEC(CNT)
- SET ECC=+$PIECE(ECNODE,"^")
- SET ECP=$PIECE(ECNODE,"^",2)
- SET ECPRPTR=$PIECE(ECNODE,"^",12)
- +4 SET ECCPT=$PIECE(ECNODE,"^",9)
- +5 ; set the zero node
- +6 SET ^ECH(ECFN,0)=ECFN_"^"_ECPS_"^"_ECDT_"^"_ECL_"^"_ECS_"^"_ECM_"^"_ECD_"^"_ECC_"^"_ECP_"^"_ECV_"^^"_ECO_"^"_ECDUZ_"^^^^^^"_EC4_"^"_ECID_"^"_ECVST_"^"_ECINP
- +7 ;ALB/JAM file multiple providers (EC*2*72)
- +8 SET ECFIL=$$FILPRV^ECPRVMUT(ECFN,.ECPRVARY,.ECOUT)
- KILL ECFIL
- +9 ;ALB/ESD - Set procedure reason into zero node
- +10 IF +ECPRPTR
- SET $PIECE(^ECH(ECFN,0),"^",23)=+ECPRPTR
- +11 ;set the "P" node
- +12 SET ^ECH(ECFN,"P")=ECCPT_"^"_ECDX_"^"_ECAO_"^"_ECIR_"^"_ECZEC_"^"_ECSC
- +13 SET $PIECE(^ECH(ECFN,"P"),"^",9,12)=ECMST_"^"_ECHNC_"^"_ECCV_"^"_ECSHAD
- +14 ;add secondary diagnosis codes
- +15 IF $ORDER(ECPT(CNT1,"DXS",""))'=""
- Begin DoDot:1
- +16 SET DXS=""
- FOR
- SET DXS=$ORDER(ECPT(CNT1,"DXS",DXS))
- if DXS=""
- QUIT
- Begin DoDot:2
- +17 SET DXSIEN=$PIECE(ECPT(CNT1,"DXS",DXS),U)
- IF DXSIEN<0
- QUIT
- +18 KILL DIC,DD,DO
- +19 SET DIC(0)="L"
- SET DA(1)=ECFN
- SET DIC="^ECH("_DA(1)_","_"""DX"""_","
- +20 SET DIC("P")=$PIECE(^DD(721,38,0),U,2)
- SET X=DXSIEN
- +21 DO FILE^DICN
- End DoDot:2
- End DoDot:1
- KILL DXSIEN,DXS
- +22 KILL ECDXX
- MERGE ECDXX=ECPT(CNT1,"DXS")
- +23 SET PXUPD=$$PXUPD^ECUTL2(ECPS,ECDT,ECL,EC4,ECDX,.ECDXX,ECFN)
- KILL PXUPD,ECDXX
- +24 ;add CPT procedure modifiers
- +25 IF $ORDER(ECEC(CNT,"MOD",""))'=""
- Begin DoDot:1
- +26 SET MOD=""
- FOR
- SET MOD=$ORDER(ECEC(CNT,"MOD",MOD))
- if MOD=""
- QUIT
- Begin DoDot:2
- +27 SET MODIEN=$PIECE(ECEC(CNT,"MOD",MOD),U,2)
- IF MODIEN<0
- QUIT
- +28 KILL DIC,DD,DO
- +29 SET DIC(0)="L"
- SET DA(1)=ECFN
- SET DIC="^ECH("_DA(1)_","_"""MOD"""_","
- +30 SET DIC("P")=$PIECE(^DD(721,36,0),U,2)
- SET X=MODIEN
- +31 DO FILE^DICN
- End DoDot:2
- End DoDot:1
- KILL MODIEN,MOD
- XREF ; sets crossreferences
- +1 SET DIK="^ECH("
- SET DA=ECFN
- DO IX1^DIK
- KILL DA,DIK
- PCE ;format data to send PCE
- +1 if $PIECE(ECPCE,"~",2)="N"
- QUIT
- IF $PIECE(ECPCE,"~",2)="O"&(ECINP'="O")
- QUIT
- +2 DO PCE^ECBEN2U
- +3 QUIT
