IBERSE ;ALB/ARH - BUILD CHECK-OFF SHEET (350.7&350.71); 11/18/91
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
S IBERSCE=1 D HOME^%ZIS W @IOF,?22,"Build Check-Off Sheets",!!!!!!!
ENTG ;enter/edit group information (350.7)
S DIC("A")="Select Check-Off Sheet: "
S DIC="^IBE(350.7,",DIC(0)="AELQ" D ^DIC K DIC G:Y<0 ENDG S IBGRP=+Y
I '$P(Y,"^",3) S DIR(0)="Y",DIR("A")="Edit this CHECK-OFF SHEET",DIR("B")="NO" D ^DIR K DIR G G4:$D(DIRUT),G3:'Y
G1 S DA=IBGRP,DIE="^IBE(350.7,",DR=".01:.04",DIE("NO^")="BACK" D ^DIE K DIE,DIC,DR,Y I '$D(DA) D DELGRP G G4
K DA S IBX=$$FORMAT^IBEFUNC2(IBGRP,"") I $L($P($G(^IBE(350.7,IBGRP,0)),"^",1))>$P(IBX,"^",2) W !!,"Name too long, will not fit format entered.",!! G G1
G2 S DIC("A")="Select CLINIC: ",DIC="^SC(",DIC(0)="AEQ",DIC("S")="I $P(^(0),U,3)=""C""" D ^DIC K DIC
I Y'<0 S DA=+Y,DIE="^SC(",DR="25//"_$P(^IBE(350.7,+IBGRP,0),"^") D ^DIE K DIE,DIC,DR,DA,Y G G2
G3 D GDISP,CAT,PRINT
G4 W ! G ENTG
ENDG K DA,DR,Y,X,IBGRP,IBPFN,IBX,IBERSCE,DTOUT,DUOUT,DIRUT,DIROUT
Q
;
CAT ;enter/edit sub-header information (350.71)
S DIC("A")="Select SUB-HEADER: ",DIC("S")="I $D(^(0)),$P(^(0),U,3)=""S"",$P(^(0),U,4)="_IBGRP
S DIC="^IBE(350.71,",DIC(0)="AEQL" D ^DIC K DIC G ENDC:Y<0 S IBCFN=+Y
I '$P(Y,"^",3) S DIR(0)="Y",DIR("A")=" Edit SUB-HEADER",DIR("B")="NO" D ^DIR K DIR G C2:$D(DIRUT),C1:'Y
S DA=IBCFN,DIE="^IBE(350.71,",DR=".03///S;.04////"_IBGRP_";.01;.02",DIE("NO^")="BACK" D ^DIE K DIE,DIC,DR,Y I '$D(DA) D DELCAT G C2
C1 D CDISP,PROC,GDISP
C2 G CAT
ENDC K X,Y,IBCFN,DA,DUOUT,DTOUT
Q
;
PROC ;enter/edit procedure information (350.71)
S DIR("A")=" Select a PROCEDURE",DIR("?")="^D CDISP^IBERSE"
S DIR(0)="409.71,.01O" D ^DIR K DIR,DINUM G ENDP:Y<1 S IBCODE=+Y
I $$CPTSTAT^IBEFUNC2(IBCODE,DT)'>1 W !!,?5,"CPT not active Nationally, Locally, or in Billing!",!! G PROC
S IBNM=$P($G(^ICPT(IBCODE,0)),"^",2),IBPFN=$O(^IBE(350.71,"AP",IBCFN,IBCODE,0))
I 'IBPFN K DD,DO S DIC(0)="",DIC="^IBE(350.71,",X=IBNM D FILE^DICN K DIC S IBPFN=+Y
S DA=IBPFN,DIE="^IBE(350.71,",DR=".03///P;.05////"_IBCFN_";.06////"_IBCODE_";.01;.02",DIE("NO^")="BACK" D ^DIE K DIE,DIC,DR,DA,Y
G PROC
ENDP K X,Y,IBPFN,IBCODE,IBNM,DA,DUOUT,DTOUT,DIRUT,DIROUT
Q
;
GDISP ;display the groups data (350.7)
S X="IBXCPTG" X ^%ZOSF("TEST") Q:'$T
W:$D(IOF) @IOF,?25,"Ambulatory Surgery Check-Off Sheet Profile"
S D0=IBGRP D ^IBXCPTG K X,DXS,D0
Q
CDISP ;display the field data (350.71)
S X="IBXCPTC" X ^%ZOSF("TEST") Q:'$T
W:$D(IOF) @IOF,?25,"Ambulatory Surgery Sub-header Profile"
S D0=IBCFN D ^IBXCPTC K X,DXS,D0
Q
;
DELGRP ;delete a sheets members - including the sheets sub-header members, and the entry in 44
W !!,"Deleting SHEET members, please wait....",!!
S IBPO="" F IBI=1:1 S IBPO=$O(^IBE(350.71,"AG",IBGRP,IBPO)) Q:IBPO="" S IBCFN=$O(^(IBPO,"")) D DC1 S DIK="^IBE(350.71,",DA=IBCFN D ^DIK K DIK
I $D(^SC("AF",IBGRP)) S IBCLN="" F S IBCLN=$O(^SC("AF",IBGRP,IBCLN)) Q:IBCLN="" S DA=IBCLN,DIE="^SC(",DR="25////@" D ^DIE K DIE,DIC,DR,DA,Y
ENDGP K IBI,IBPO,IBCLN,DA
Q
;
DELCAT ;delete a sub-header's members
W !!,"Deleting SUB-HEADER members, please wait...",!!
DC1 S IBPPO="" F IBJ=1:1 S IBPPO=$O(^IBE(350.71,"AS",IBCFN,IBPPO)) Q:IBPPO="" S IBPFN=$O(^(IBPPO,"")) S DIK="^IBE(350.71,",DA=IBPFN D ^DIK K DIK
ENDCT K IBJ,IBPPO,DA
Q
;
PRINT ;print the check-off sheet
S DIR(0)="Y",DIR("A")="Print this SHEET",DIR("B")="NO" D ^DIR K DIR Q:'Y
W !,"This report requires a 132 column printer."
S %ZIS="QM" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="RQT^IBERSP",ZTSAVE("IBG("_IBGRP_")")="1",ZTDESC="A.S. Check-Off Sheet" D ^%ZTLOAD K IO("Q") D HOME^%ZIS Q
U IO D CPT^IBERSP(IBGRP,"",0,DT,1) D ^%ZISC
K ^TMP("IBRSC",$J),DTOUT,DUOUT,DIRUT,DIROUT,X,Y
Q
IBERSE ;ALB/ARH - BUILD CHECK-OFF SHEET (350.7&350.71); 11/18/91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 SET IBERSCE=1
DO HOME^%ZIS
WRITE @IOF,?22,"Build Check-Off Sheets",!!!!!!!
ENTG ;enter/edit group information (350.7)
+1 SET DIC("A")="Select Check-Off Sheet: "
+2 SET DIC="^IBE(350.7,"
SET DIC(0)="AELQ"
DO ^DIC
KILL DIC
IF Y<0
GOTO ENDG
SET IBGRP=+Y
+3 IF '$PIECE(Y,"^",3)
SET DIR(0)="Y"
SET DIR("A")="Edit this CHECK-OFF SHEET"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO G4
IF 'Y
GOTO G3
G1 SET DA=IBGRP
SET DIE="^IBE(350.7,"
SET DR=".01:.04"
SET DIE("NO^")="BACK"
DO ^DIE
KILL DIE,DIC,DR,Y
IF '$DATA(DA)
DO DELGRP
GOTO G4
+1 KILL DA
SET IBX=$$FORMAT^IBEFUNC2(IBGRP,"")
IF $LENGTH($PIECE($GET(^IBE(350.7,IBGRP,0)),"^",1))>$PIECE(IBX,"^",2)
WRITE !!,"Name too long, will not fit format entered.",!!
GOTO G1
G2 SET DIC("A")="Select CLINIC: "
SET DIC="^SC("
SET DIC(0)="AEQ"
SET DIC("S")="I $P(^(0),U,3)=""C"""
DO ^DIC
KILL DIC
+1 IF Y'<0
SET DA=+Y
SET DIE="^SC("
SET DR="25//"_$PIECE(^IBE(350.7,+IBGRP,0),"^")
DO ^DIE
KILL DIE,DIC,DR,DA,Y
GOTO G2
G3 DO GDISP
DO CAT
DO PRINT
G4 WRITE !
GOTO ENTG
ENDG KILL DA,DR,Y,X,IBGRP,IBPFN,IBX,IBERSCE,DTOUT,DUOUT,DIRUT,DIROUT
+1 QUIT
+2 ;
CAT ;enter/edit sub-header information (350.71)
+1 SET DIC("A")="Select SUB-HEADER: "
SET DIC("S")="I $D(^(0)),$P(^(0),U,3)=""S"",$P(^(0),U,4)="_IBGRP
+2 SET DIC="^IBE(350.71,"
SET DIC(0)="AEQL"
DO ^DIC
KILL DIC
IF Y<0
GOTO ENDC
SET IBCFN=+Y
+3 IF '$PIECE(Y,"^",3)
SET DIR(0)="Y"
SET DIR("A")=" Edit SUB-HEADER"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO C2
IF 'Y
GOTO C1
+4 SET DA=IBCFN
SET DIE="^IBE(350.71,"
SET DR=".03///S;.04////"_IBGRP_";.01;.02"
SET DIE("NO^")="BACK"
DO ^DIE
KILL DIE,DIC,DR,Y
IF '$DATA(DA)
DO DELCAT
GOTO C2
C1 DO CDISP
DO PROC
DO GDISP
C2 GOTO CAT
ENDC KILL X,Y,IBCFN,DA,DUOUT,DTOUT
+1 QUIT
+2 ;
PROC ;enter/edit procedure information (350.71)
+1 SET DIR("A")=" Select a PROCEDURE"
SET DIR("?")="^D CDISP^IBERSE"
+2 SET DIR(0)="409.71,.01O"
DO ^DIR
KILL DIR,DINUM
IF Y<1
GOTO ENDP
SET IBCODE=+Y
+3 IF $$CPTSTAT^IBEFUNC2(IBCODE,DT)'>1
WRITE !!,?5,"CPT not active Nationally, Locally, or in Billing!",!!
GOTO PROC
+4 SET IBNM=$PIECE($GET(^ICPT(IBCODE,0)),"^",2)
SET IBPFN=$ORDER(^IBE(350.71,"AP",IBCFN,IBCODE,0))
+5 IF 'IBPFN
KILL DD,DO
SET DIC(0)=""
SET DIC="^IBE(350.71,"
SET X=IBNM
DO FILE^DICN
KILL DIC
SET IBPFN=+Y
+6 SET DA=IBPFN
SET DIE="^IBE(350.71,"
SET DR=".03///P;.05////"_IBCFN_";.06////"_IBCODE_";.01;.02"
SET DIE("NO^")="BACK"
DO ^DIE
KILL DIE,DIC,DR,DA,Y
+7 GOTO PROC
ENDP KILL X,Y,IBPFN,IBCODE,IBNM,DA,DUOUT,DTOUT,DIRUT,DIROUT
+1 QUIT
+2 ;
GDISP ;display the groups data (350.7)
+1 SET X="IBXCPTG"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+2 IF $DATA(IOF)
WRITE @IOF,?25,"Ambulatory Surgery Check-Off Sheet Profile"
+3 SET D0=IBGRP
DO ^IBXCPTG
KILL X,DXS,D0
+4 QUIT
CDISP ;display the field data (350.71)
+1 SET X="IBXCPTC"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+2 IF $DATA(IOF)
WRITE @IOF,?25,"Ambulatory Surgery Sub-header Profile"
+3 SET D0=IBCFN
DO ^IBXCPTC
KILL X,DXS,D0
+4 QUIT
+5 ;
DELGRP ;delete a sheets members - including the sheets sub-header members, and the entry in 44
+1 WRITE !!,"Deleting SHEET members, please wait....",!!
+2 SET IBPO=""
FOR IBI=1:1
SET IBPO=$ORDER(^IBE(350.71,"AG",IBGRP,IBPO))
IF IBPO=""
QUIT
SET IBCFN=$ORDER(^(IBPO,""))
DO DC1
SET DIK="^IBE(350.71,"
SET DA=IBCFN
DO ^DIK
KILL DIK
+3 IF $DATA(^SC("AF",IBGRP))
SET IBCLN=""
FOR
SET IBCLN=$ORDER(^SC("AF",IBGRP,IBCLN))
IF IBCLN=""
QUIT
SET DA=IBCLN
SET DIE="^SC("
SET DR="25////@"
DO ^DIE
KILL DIE,DIC,DR,DA,Y
ENDGP KILL IBI,IBPO,IBCLN,DA
+1 QUIT
+2 ;
DELCAT ;delete a sub-header's members
+1 WRITE !!,"Deleting SUB-HEADER members, please wait...",!!
DC1 SET IBPPO=""
FOR IBJ=1:1
SET IBPPO=$ORDER(^IBE(350.71,"AS",IBCFN,IBPPO))
IF IBPPO=""
QUIT
SET IBPFN=$ORDER(^(IBPPO,""))
SET DIK="^IBE(350.71,"
SET DA=IBPFN
DO ^DIK
KILL DIK
ENDCT KILL IBJ,IBPPO,DA
+1 QUIT
+2 ;
PRINT ;print the check-off sheet
+1 SET DIR(0)="Y"
SET DIR("A")="Print this SHEET"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF 'Y
QUIT
+2 WRITE !,"This report requires a 132 column printer."
+3 SET %ZIS="QM"
DO ^%ZIS
IF POP
QUIT
+4 IF $DATA(IO("Q"))
SET ZTRTN="RQT^IBERSP"
SET ZTSAVE("IBG("_IBGRP_")")="1"
SET ZTDESC="A.S. Check-Off Sheet"
DO ^%ZTLOAD
KILL IO("Q")
DO HOME^%ZIS
QUIT
+5 USE IO
DO CPT^IBERSP(IBGRP,"",0,DT,1)
DO ^%ZISC
+6 KILL ^TMP("IBRSC",$JOB),DTOUT,DUOUT,DIRUT,DIROUT,X,Y
+7 QUIT
