ECBENF ;BIR/MAM,JPW-Stuff New Batched Procedures ;12 Feb 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
.S ECNODE2=$G(ECPT(CNT1))
.S ECELIG=$G(ECELPT(CNT1))
.S ECPS=$P(ECNODE2,"^"),ECDX=$P(ECNODE2,"^",3),ECINP=$P(ECNODE2,"^",4),ECVST=$P(ECNODE2,"^",5),ECSC=$P(ECNODE2,"^",6),ECAO=$P(ECNODE2,"^",7),ECIR=$P(ECNODE2,"^",8),ECZEC=$P(ECNODE2,"^",9),ECMST=$P(ECNODE2,"^",12)
.S ECHNC=$P(ECNODE2,"^",13),ECCV=$P(ECNODE2,"^",14),ECSHAD=$P(ECNODE2,"^",15)
.F S CNT=$O(ECEC(CNT)) Q:'CNT D
..S EC4=$P(ECNODE2,"^",10),ECID=$P(ECNODE2,"^",11)
..D NODE D DIE
END D ^ECKILL K DLAYGO S:$D(ZTQUEUED) ZTREQ="@"
Q
NODE ;set patient array data
S ECNODE=ECEC(CNT)
S ECC=+$P(ECNODE,"^"),ECP=$P(ECNODE,"^",2),ECO=$P(ECNODE,"^",4),ECV=$P(ECNODE,"^",5)
S ECCPT=$P(ECNODE,"^",11),ECPRPTR=$P(ECNODE,"^",12)
;
;- Get associated clinic from event code screen if null
S:$G(EC4)="" EC4=$P($G(^ECJ(+$O(^ECJ("AP",+ECL,+ECD,+ECC,$G(ECP),0)),"PRO")),"^",4)
S:$G(ECID)="" ECID=$P($G(^SC(+EC4,0)),"^",7)
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
; 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/JAM 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
; 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
; ALB/JAM - 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
XREF ; sets crossreferences
S DIK="^ECH(",DA=ECFN D IX1^DIK K DA,DIK
;
PCE ;format PCE data to send
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[HECBENF 2990 printed Nov 22, 2024@17:07:03 Page 2
ECBENF ;BIR/MAM,JPW-Stuff New Batched Procedures ;12 Feb 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
+4 FOR
SET CNT1=$ORDER(ECPT(CNT1))
if 'CNT1
QUIT
Begin DoDot:1
+5 SET ECNODE2=$GET(ECPT(CNT1))
+6 SET ECELIG=$GET(ECELPT(CNT1))
+7 SET ECPS=$PIECE(ECNODE2,"^")
SET ECDX=$PIECE(ECNODE2,"^",3)
SET ECINP=$PIECE(ECNODE2,"^",4)
SET ECVST=$PIECE(ECNODE2,"^",5)
SET ECSC=$PIECE(ECNODE2,"^",6)
SET ECAO=$PIECE(ECNODE2,"^",7)
SET ECIR=$PIECE(ECNODE2,"^",8)
SET ECZEC=$PIECE(ECNODE2,"^",9)
SET ECMST=$PIECE(ECNODE2,"^",12)
+8 SET ECHNC=$PIECE(ECNODE2,"^",13)
SET ECCV=$PIECE(ECNODE2,"^",14)
SET ECSHAD=$PIECE(ECNODE2,"^",15)
+9 FOR
SET CNT=$ORDER(ECEC(CNT))
if 'CNT
QUIT
Begin DoDot:2
+10 SET EC4=$PIECE(ECNODE2,"^",10)
SET ECID=$PIECE(ECNODE2,"^",11)
+11 DO NODE
DO DIE
End DoDot:2
End DoDot:1
END DO ^ECKILL
KILL DLAYGO
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 QUIT
NODE ;set patient array data
+1 SET ECNODE=ECEC(CNT)
+2 SET ECC=+$PIECE(ECNODE,"^")
SET ECP=$PIECE(ECNODE,"^",2)
SET ECO=$PIECE(ECNODE,"^",4)
SET ECV=$PIECE(ECNODE,"^",5)
+3 SET ECCPT=$PIECE(ECNODE,"^",11)
SET ECPRPTR=$PIECE(ECNODE,"^",12)
+4 ;
+5 ;- Get associated clinic from event code screen if null
+6 if $GET(EC4)=""
SET EC4=$PIECE($GET(^ECJ(+$ORDER(^ECJ("AP",+ECL,+ECD,+ECC,$GET(ECP),0)),"PRO")),"^",4)
+7 if $GET(ECID)=""
SET ECID=$PIECE($GET(^SC(+EC4,0)),"^",7)
+8 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 the zero node
+4 SET ^ECH(ECFN,0)=ECFN_"^"_ECPS_"^"_ECDT_"^"_ECL_"^"_ECS_"^"_ECM_"^"_ECD_"^"_ECC_"^"_ECP_"^"_ECV_"^^"_ECO_"^"_ECDUZ_"^^^^^^"_EC4_"^"_ECID_"^"_ECVST_"^"_ECINP
+5 ;ALB/JAM file multiple providers (EC*2*72)
+6 SET ECFIL=$$FILPRV^ECPRVMUT(ECFN,.ECPRVARY,.ECOUT)
KILL ECFIL
+7 ;
+8 ; ALB/JAM add CPT procedure modifiers
+9 IF $ORDER(ECEC(CNT,"MOD",""))'=""
Begin DoDot:1
+10 SET MOD=""
FOR
SET MOD=$ORDER(ECEC(CNT,"MOD",MOD))
if MOD=""
QUIT
Begin DoDot:2
+11 SET MODIEN=$PIECE(ECEC(CNT,"MOD",MOD),U,2)
IF MODIEN<0
QUIT
+12 KILL DIC,DD,DO
+13 SET DIC(0)="L"
SET DA(1)=ECFN
SET DIC="^ECH("_DA(1)_","_"""MOD"""_","
+14 SET DIC("P")=$PIECE(^DD(721,36,0),U,2)
SET X=MODIEN
+15 DO FILE^DICN
End DoDot:2
End DoDot:1
KILL MODIEN,MOD
+16 ; ALB/ESD - Set procedure reason into zero node
+17 IF +ECPRPTR
SET $PIECE(^ECH(ECFN,0),"^",23)=+ECPRPTR
+18 ;set the "P" node
+19 SET ^ECH(ECFN,"P")=ECCPT_"^"_ECDX_"^"_ECAO_"^"_ECIR_"^"_ECZEC_"^"_ECSC
+20 SET $PIECE(^ECH(ECFN,"P"),"^",9,12)=ECMST_"^"_ECHNC_"^"_ECCV_"^"_ECSHAD
+21 ; ALB/JAM - add secondary diagnosis codes
+22 IF $ORDER(ECPT(CNT1,"DXS",""))'=""
Begin DoDot:1
+23 SET DXS=""
FOR
SET DXS=$ORDER(ECPT(CNT1,"DXS",DXS))
if DXS=""
QUIT
Begin DoDot:2
+24 SET DXSIEN=$PIECE(ECPT(CNT1,"DXS",DXS),U)
IF DXSIEN<0
QUIT
+25 KILL DIC,DD,DO
+26 SET DIC(0)="L"
SET DA(1)=ECFN
SET DIC="^ECH("_DA(1)_","_"""DX"""_","
+27 SET DIC("P")=$PIECE(^DD(721,38,0),U,2)
SET X=DXSIEN
+28 DO FILE^DICN
End DoDot:2
End DoDot:1
KILL DXSIEN,DXS
+29 KILL ECDXX
MERGE ECDXX=ECPT(CNT1,"DXS")
+30 SET PXUPD=$$PXUPD^ECUTL2(ECPS,ECDT,ECL,EC4,ECDX,.ECDXX,ECFN)
KILL PXUPD,ECDXX
XREF ; sets crossreferences
+1 SET DIK="^ECH("
SET DA=ECFN
DO IX1^DIK
KILL DA,DIK
+2 ;
PCE ;format PCE data to send
+1 if $PIECE(ECPCE,"~",2)="N"
QUIT
IF $PIECE(ECPCE,"~",2)="O"&(ECINP'="O")
QUIT
+2 DO PCE^ECBEN2U
+3 QUIT
