- IBERSP ;ALB/ARH - CREATE/PRINT CHECK-OFF SHEET CPT LIST ; 11/5/91
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;request ambulatory surgery check-off sheet by group ie. not for an appointment
- ;***
- ;S XRTL=$ZU(0),XRTN="IBERSP-1" D T0^%ZOSV ;start rt clock
- D HOME^%ZIS W @IOF,!!,?20,"Print Clinic Check-Off Sheet",!!!
- SLT S DIC="^IBE(350.7,",DIC(0)="AEQ" D ^DIC K DIC I Y>0 S IBG(+Y)="" G SLT
- G:'$D(IBG) END
- W !!,"This report requires a 132 column printer." S %ZIS="QM" D ^%ZIS G:POP END
- I $D(IO("Q")) S ZTRTN="RQT^IBERSP",ZTSAVE("IBG(")="",ZTDESC="A.S. Check-Off Sheets" D ^%ZTLOAD K IO("Q") D HOME^%ZIS G END
- U IO
- ;***
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBERSP" D T1^%ZOSV ;stop rt clock
- D RQT
- END ;
- ;***
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBERSP" D T1^%ZOSV ;stop rt clock
- I $D(ZTQUEUED) S ZTREQ="@" Q
- K DTOUT,DUOUT,IBG,X,Y D ^%ZISC
- Q
- ;(possible) external entry pt.
- ;print requested check-off sheets for groups in IBG (without patient data, with box)
- RQT ;
- ;***
- ;S XRTL=$ZU(0),XRTN="IBERSP-2" D T0^%ZOSV ;start rt clock
- S IBGRP="" F S IBGRP=$O(IBG(IBGRP)) Q:IBGRP="" D CPT(IBGRP,"",0,DT,1) W @IOF Q:$$STOP^IBERS1
- K IBG,IBGRP,^TMP("IBRSC",$J)
- ;***
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBERSP" D T1^%ZOSV ;stop rt clock
- G END
- ;
- ;external entry point
- CPT(GRP,DIV,TOF,ADT,BOX) ;prints the CPT list for particular group
- ;print device must be defined, opened and the paper set on the line that printing is to begin on
- ;does not close the device when done or set printer to TOF
- ;Inputs: GRP = the IFN (350.7) of the group to be printed
- ; DIV = division of clinic, needed for charge calculation
- ; DT = date of appointment, needed for charge calculation (DT if "")
- ; TOF = top of form, the line number at which to begin printing
- ; BOX = true if a card box should be printed in upper left corner
- ;first creates a temp file in sequential format, then prints that file in column format
- ;whoever calls this must delete ^TMP("IBRSC") themselves after they have printed all lists,
- ;it is not killed here to speed up CPT lists by already having them partially formated for reuse
- D:'$D(^TMP("IBRSC",$J,GRP)) CREATE^IBERSP1 Q:'$D(^TMP("IBRSC",$J,GRP))
- I BOX D:'$D(^TMP("IBRSC",$J,"B")) BOX^IBERSP1 D PRNTBX
- D PRINT
- Q
- ;
- PRINT ;reformats list into multiple columns for specific TOF then prints it out
- N CAT,COL,PG,GCOL,HDR,LN,CW,MAXLN,MINLN,LINE,CONT,CHDR,SL,I,J,X,Y,N
- Q:'$D(^TMP("IBRSC",$J,+GRP))
- S SL=IOSL,CAT=0,(MAXLN,LN,MINLN,COL)=1,PG=$S(BOX:1,1:0),GCOL=^TMP("IBRSC",$J,GRP),HDR=^TMP("IBRSC",$J,GRP,0)
- S HDR="CPT Codes for "_HDR,HDR=$J(HDR,IOM/2+($L(HDR)\2)) D:'BOX HDR
- F I=1:1 S CAT=$O(^TMP("IBRSC",$J,GRP,CAT)) Q:CAT="" D
- . S CONT=0 F Q:SL'<(LN+TOF+3) D NEWCOL
- . S CHDR=^TMP("IBRSC",$J,GRP,CAT,0),CW=$L(CHDR),N=0 F X="",CHDR D PL
- . F J=1:1 S N=$O(^TMP("IBRSC",$J,GRP,CAT,N)) Q:N="" D
- .. S LINE=^(N) F Q:SL>(LN+TOF) S CONT=1 D NEWCOL
- .. S X=LINE D PL
- D P1 K ^TMP("IBRSC",$J,"F")
- Q
- ;
- PL ;sets each formated line into temp file, X is added to the end of the current line,
- ;then the line is padded with spaces to the end of the column (plus # IC spaces)
- S Y=$G(^TMP("IBRSC",$J,"F",PG,LN)),Y=Y_$J("",((CW*(COL-1))-$L(Y)))
- S ^TMP("IBRSC",$J,"F",PG,LN)=Y_X,LN=LN+1 S:LN>MAXLN MAXLN=LN
- Q
- ;
- NEWCOL ;go to next column, or next page
- S COL=COL+1 D:COL>GCOL HDR S LN=MINLN I CONT F X="",CHDR D PL
- Q
- ;
- HDR ;set GROUP header into the temp file
- S LN=1,PG=PG+1 I COL>GCOL S TOF=0
- S Y=HDR,^TMP("IBRSC",$J,"F",PG,LN)=Y,LN=LN+1,COL=1,MINLN=LN
- Q
- ;
- P1 ;print each line of finally formated temp file
- S X="" F I=1:1 S X=$O(^TMP("IBRSC",$J,"F",X)) Q:X'?1N.N W:X>1 @IOF S Y="" F J=1:1 S Y=$O(^TMP("IBRSC",$J,"F",X,Y)) Q:Y="" W !,^TMP("IBRSC",$J,"F",X,Y)
- Q
- ;
- PRNTBX ;print a box in upper left corner and title
- N HDR,CTR,IBLG,I5,I6,X,I
- S HDR=^TMP("IBRSC",$J,GRP,0),CTR=$G(^TMP("IBRSC",$J,"B")),IBLG=$S(($L(HDR)+30)>CTR:1,1:0),CTR=CTR\2
- S I6=$S(IBLG:$J(HDR,CTR+($L(HDR)\2)),1:"")
- S I5=$S(IBLG:$J("CPT Codes for ",(CTR+7)),1:$J("CPT Codes for "_HDR,CTR+7+($L(HDR)\2)))
- S X="" F I=1:1 S X=$O(^TMP("IBRSC",$J,"B",X)) Q:X="" W !,^TMP("IBRSC",$J,"B",X)_$S($D(@("I"_I)):@("I"_I),1:"")
- S TOF=(TOF+I+1)
- Q
- IBERSP ;ALB/ARH - CREATE/PRINT CHECK-OFF SHEET CPT LIST ; 11/5/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 ;request ambulatory surgery check-off sheet by group ie. not for an appointment
- +5 ;***
- +6 ;S XRTL=$ZU(0),XRTN="IBERSP-1" D T0^%ZOSV ;start rt clock
- +7 DO HOME^%ZIS
- WRITE @IOF,!!,?20,"Print Clinic Check-Off Sheet",!!!
- SLT SET DIC="^IBE(350.7,"
- SET DIC(0)="AEQ"
- DO ^DIC
- KILL DIC
- IF Y>0
- SET IBG(+Y)=""
- GOTO SLT
- +1 IF '$DATA(IBG)
- GOTO END
- +2 WRITE !!,"This report requires a 132 column printer."
- SET %ZIS="QM"
- DO ^%ZIS
- IF POP
- GOTO END
- +3 IF $DATA(IO("Q"))
- SET ZTRTN="RQT^IBERSP"
- SET ZTSAVE("IBG(")=""
- SET ZTDESC="A.S. Check-Off Sheets"
- DO ^%ZTLOAD
- KILL IO("Q")
- DO HOME^%ZIS
- GOTO END
- +4 USE IO
- +5 ;***
- +6 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBERSP" D T1^%ZOSV ;stop rt clock
- +7 DO RQT
- END ;
- +1 ;***
- +2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBERSP" D T1^%ZOSV ;stop rt clock
- +3 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +4 KILL DTOUT,DUOUT,IBG,X,Y
- DO ^%ZISC
- +5 QUIT
- +6 ;(possible) external entry pt.
- +7 ;print requested check-off sheets for groups in IBG (without patient data, with box)
- RQT ;
- +1 ;***
- +2 ;S XRTL=$ZU(0),XRTN="IBERSP-2" D T0^%ZOSV ;start rt clock
- +3 SET IBGRP=""
- FOR
- SET IBGRP=$ORDER(IBG(IBGRP))
- IF IBGRP=""
- QUIT
- DO CPT(IBGRP,"",0,DT,1)
- WRITE @IOF
- IF $$STOP^IBERS1
- QUIT
- +4 KILL IBG,IBGRP,^TMP("IBRSC",$JOB)
- +5 ;***
- +6 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBERSP" D T1^%ZOSV ;stop rt clock
- +7 GOTO END
- +8 ;
- +9 ;external entry point
- CPT(GRP,DIV,TOF,ADT,BOX) ;prints the CPT list for particular group
- +1 ;print device must be defined, opened and the paper set on the line that printing is to begin on
- +2 ;does not close the device when done or set printer to TOF
- +3 ;Inputs: GRP = the IFN (350.7) of the group to be printed
- +4 ; DIV = division of clinic, needed for charge calculation
- +5 ; DT = date of appointment, needed for charge calculation (DT if "")
- +6 ; TOF = top of form, the line number at which to begin printing
- +7 ; BOX = true if a card box should be printed in upper left corner
- +8 ;first creates a temp file in sequential format, then prints that file in column format
- +9 ;whoever calls this must delete ^TMP("IBRSC") themselves after they have printed all lists,
- +10 ;it is not killed here to speed up CPT lists by already having them partially formated for reuse
- +11 IF '$DATA(^TMP("IBRSC",$JOB,GRP))
- DO CREATE^IBERSP1
- IF '$DATA(^TMP("IBRSC",$JOB,GRP))
- QUIT
- +12 IF BOX
- IF '$DATA(^TMP("IBRSC",$JOB,"B"))
- DO BOX^IBERSP1
- DO PRNTBX
- +13 DO PRINT
- +14 QUIT
- +15 ;
- PRINT ;reformats list into multiple columns for specific TOF then prints it out
- +1 NEW CAT,COL,PG,GCOL,HDR,LN,CW,MAXLN,MINLN,LINE,CONT,CHDR,SL,I,J,X,Y,N
- +2 IF '$DATA(^TMP("IBRSC",$JOB,+GRP))
- QUIT
- +3 SET SL=IOSL
- SET CAT=0
- SET (MAXLN,LN,MINLN,COL)=1
- SET PG=$SELECT(BOX:1,1:0)
- SET GCOL=^TMP("IBRSC",$JOB,GRP)
- SET HDR=^TMP("IBRSC",$JOB,GRP,0)
- +4 SET HDR="CPT Codes for "_HDR
- SET HDR=$JUSTIFY(HDR,IOM/2+($LENGTH(HDR)\2))
- IF 'BOX
- DO HDR
- +5 FOR I=1:1
- SET CAT=$ORDER(^TMP("IBRSC",$JOB,GRP,CAT))
- IF CAT=""
- QUIT
- Begin DoDot:1
- +6 SET CONT=0
- FOR
- IF SL'<(LN+TOF+3)
- QUIT
- DO NEWCOL
- +7 SET CHDR=^TMP("IBRSC",$JOB,GRP,CAT,0)
- SET CW=$LENGTH(CHDR)
- SET N=0
- FOR X="",CHDR
- DO PL
- +8 FOR J=1:1
- SET N=$ORDER(^TMP("IBRSC",$JOB,GRP,CAT,N))
- IF N=""
- QUIT
- Begin DoDot:2
- +9 SET LINE=^(N)
- FOR
- IF SL>(LN+TOF)
- QUIT
- SET CONT=1
- DO NEWCOL
- +10 SET X=LINE
- DO PL
- End DoDot:2
- End DoDot:1
- +11 DO P1
- KILL ^TMP("IBRSC",$JOB,"F")
- +12 QUIT
- +13 ;
- PL ;sets each formated line into temp file, X is added to the end of the current line,
- +1 ;then the line is padded with spaces to the end of the column (plus # IC spaces)
- +2 SET Y=$GET(^TMP("IBRSC",$JOB,"F",PG,LN))
- SET Y=Y_$JUSTIFY("",((CW*(COL-1))-$LENGTH(Y)))
- +3 SET ^TMP("IBRSC",$JOB,"F",PG,LN)=Y_X
- SET LN=LN+1
- IF LN>MAXLN
- SET MAXLN=LN
- +4 QUIT
- +5 ;
- NEWCOL ;go to next column, or next page
- +1 SET COL=COL+1
- IF COL>GCOL
- DO HDR
- SET LN=MINLN
- IF CONT
- FOR X="",CHDR
- DO PL
- +2 QUIT
- +3 ;
- HDR ;set GROUP header into the temp file
- +1 SET LN=1
- SET PG=PG+1
- IF COL>GCOL
- SET TOF=0
- +2 SET Y=HDR
- SET ^TMP("IBRSC",$JOB,"F",PG,LN)=Y
- SET LN=LN+1
- SET COL=1
- SET MINLN=LN
- +3 QUIT
- +4 ;
- P1 ;print each line of finally formated temp file
- +1 SET X=""
- FOR I=1:1
- SET X=$ORDER(^TMP("IBRSC",$JOB,"F",X))
- IF X'?1N.N
- QUIT
- IF X>1
- WRITE @IOF
- SET Y=""
- FOR J=1:1
- SET Y=$ORDER(^TMP("IBRSC",$JOB,"F",X,Y))
- IF Y=""
- QUIT
- WRITE !,^TMP("IBRSC",$JOB,"F",X,Y)
- +2 QUIT
- +3 ;
- PRNTBX ;print a box in upper left corner and title
- +1 NEW HDR,CTR,IBLG,I5,I6,X,I
- +2 SET HDR=^TMP("IBRSC",$JOB,GRP,0)
- SET CTR=$GET(^TMP("IBRSC",$JOB,"B"))
- SET IBLG=$SELECT(($LENGTH(HDR)+30)>CTR:1,1:0)
- SET CTR=CTR\2
- +3 SET I6=$SELECT(IBLG:$JUSTIFY(HDR,CTR+($LENGTH(HDR)\2)),1:"")
- +4 SET I5=$SELECT(IBLG:$JUSTIFY("CPT Codes for ",(CTR+7)),1:$JUSTIFY("CPT Codes for "_HDR,CTR+7+($LENGTH(HDR)\2)))
- +5 SET X=""
- FOR I=1:1
- SET X=$ORDER(^TMP("IBRSC",$JOB,"B",X))
- IF X=""
- QUIT
- WRITE !,^TMP("IBRSC",$JOB,"B",X)_$SELECT($DATA(@("I"_I)):@("I"_I),1:"")
- +6 SET TOF=(TOF+I+1)
- +7 QUIT
