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, 2024@23:06:57 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