IBERSE.m

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