- IBARXEPL ;ALB/AAS - PRINT EXEMPTION LETTER - 28-APR-93
- ;;2.0;INTEGRATED BILLING;**34,54,190,206,385**;21-MAR-94;Build 35
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- % I '$D(DT) D DT^DICRW
- I '$D(IOF) D HOME^%ZIS
- W @IOF,"Print Exemption letters to patients"
- K ^TMP("IBEX LIST",$J)
- S (IBTEMP,IBADDT,IBOK,IBQUIT)=""
- ;
- ; -- find template
- S IBTEMP=$O(^DIBT("B","IB EXEMPTION LETTER",0))
- ;
- ; -- use old template or build new one
- W !!!
- ;
- I IBTEMP D G:IBQUIT END
- .S DIR(0)="Y",DIR("A")="Delete Results of Previous Search",DIR("B")="NO"
- .S DIR("?")="Enter 'Yes' if you would like to delete the results of a previous search, Enter 'No' if you want to keep the results (i.e. you may be reprinting letters from the same list)."
- .D ^DIR K DIR I $D(DIRUT) S IBQUIT=1
- .I Y=1 D DELT S IBTEMP=0
- .Q
- ;
- I 'IBTEMP D G:IBQUIT END D:IBADD ADDT
- .S DIR(0)="Y",DIR("A")="Store results of Search in Template",DIR("B")="YES"
- .S DIR("?")="Enter 'Yes' if you would like the results of the search stored in a Sort Template named IB EXEMPTION LETTER. Enter 'No' if you do not want the template created."
- .S DIR("?",1)="Creating the search template will allow you to",DIR("?",2)="print other lists from the patients you sent the letters to."
- .S DIR("?",3)=" "
- .D ^DIR K DIR I $D(DIRUT) S IBQUIT=1 Q
- .S IBADD=Y
- .Q
- ;
- D PRINT
- ;
- END I $D(ZTQUEUED) Q
- D ^%ZISC,KVAR^VADPT
- K C,J,X,Y,D0,DIC,DA,DR,DIE,DFN,DLAYGO,DIR,DIRUT,IB,IBADD,IBADDT,IBTEMP
- K IBOK,IBLET,IBCNT,IBCNTL,IBQUIT,IBNAM,IBDATA,IBJ,IBX,TAB,POP,IBALIN
- K BY,DHD,DIOEND,FLDS,FR,I,L,TO,VAPA,^TMP("IBEX LIST",$J)
- Q
- ;
- ADDT ; -- create new template in ^dibt
- K DD,DO
- S DIC="^DIBT(",DIC(0)="L",X="IB EXEMPTION LETTER",DIC("DR")="2///NOW;4///354;7///NOW"
- D FILE^DICN S IBTEMP=+Y I +Y S IBADDT=1 W !!,"<<< Search Template IB EXEMPTION LETTER created!",!
- Q
- ;
- DELT ; -- delete search template
- Q:$P($G(^DIBT(+IBTEMP,0)),"^",1)'="IB EXEMPTION LETTER"
- S DIK="^DIBT(",DA=IBTEMP D ^DIK K DIK,DA
- W !!,"<<< Search Template IB EXEMPTION LETTER deleted!",!
- S IBTEMP=""
- Q
- ;
- SCR ; -- don't send letters to deceased patients, non-vets, vfa exempt
- ; called by print template IB DO NOT USE
- S IBOK=0 N IBX
- I +$G(^DPT(D0,.35)) G SCRQ ; deceased
- I $P($G(^DPT(D0,"VET")),"^")="N" G SCRQ ; patient non-vet
- S IBX=$P($G(^IBE(354.2,+$P($G(^IBA(354,D0,0)),"^",5),0)),"^",5)
- I IBX=60 G SCRQ ;exemption is non-vet
- I IBX=10 G SCRQ ;sc>50
- S IBOK=1
- SCRQ Q
- ;
- PRINT ; -- run through list of letters to PRINT
- S X="IB NOW EXEMPT",DIC(0)="XZ",DIC="^IBE(354.6," D ^DIC S IBLET=+Y
- Q:IBLET<1
- ;
- S DIC="^IBA(354,",L=0,FLDS="[IB DO NOT USE]",BY="[IB EXEMPT PATIENTS]",(FR,TO)="?,?,?",DHD="@@"
- S DIOEND="D LET^IBARXEPL"
- D EN1^DIP
- Q
- ;
- LET ; -- called by dioend, prints list from tmp array
- S IBALIN=$P($G(^IBE(354.6,IBLET,0)),"^",4)
- I IBALIN<10!(IBALIN>25) S IBALIN=15
- S IBNAM="" F S IBNAM=$O(^TMP("IBEX LIST",$J,IBNAM)) Q:IBNAM=""!(IBQUIT) S DFN=0 F S DFN=$O(^TMP("IBEX LIST",$J,IBNAM,DFN)) Q:'DFN!(IBQUIT) S IBDATA=^(DFN) D ONE
- D FINAL,END
- Q
- ;
- ONE ; -- print one letter
- N IBCONF ; Confidential Address Flag
- S TAB=5
- I '$D(IOF) D HOME^%ZIS
- S IBCNTL=$G(IBCNTL)+1 I $E(IOST,1,2)="C-" W @IOF
- S IB=0
- ;
- ; -- print header
- S IBCNT=0
- F I=1:1:6 S IB=$O(^IBE(354.6,IBLET,2,IB)) Q:'IB S X=$G(^(IB,0)) W !?(IOM-$L(X)+1/2),X S IBCNT=IBCNT+1
- W !?TAB S Y=DT D DT^DIQ S IBCNT=IBCNT+1
- F IBCNT=IBCNT:1:6 W ! S IBCNT=IBCNT+1
- W !?(IOM-28),"In Reply Refer To:" S IBCNT=IBCNT+1
- W !?(IOM-28),$E($P(IBDATA,"^")),$P($P(IBDATA,"^",2),"-",3),!
- S IBCNT=IBCNT+2
- ; don't print renewal date if they are VFA OK
- S IBX=$$RXST^IBARXEU(DFN,DT) I $P($G(^IBE(354.6,IBLET,0)),"^",3)'=2,$P(IBX,"^",3)=120 S Y=$$PLUS^IBARXEU0($P(IBX,"^",5)) I '$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$P(IBX,"^",5))) W ?(IOM-28),"Renewal Date: " D DT^DIQ
- ;
- ; -- print pt. name and address
- F IBCNT=IBCNT:1:(IBALIN-1) W !
- W !?TAB,$P(IBNAM,",",2)," ",$P(IBNAM,",") D ADD^VADPT S IBCNT=IBCNT+1
- S IBCONF=$$CONFADD^IBARXEL() ; Should we use Confidential Address?
- W !?TAB,VAPA($S(IBCONF:13,1:1)) S IBCNT=IBCNT+1
- I VAPA($S(IBCONF:14,1:2))'="" W !?TAB,VAPA($S(IBCONF:14,1:2)) I VAPA($S(IBCONF:15,1:3))'="" W ", ",VAPA($S(IBCONF:15,1:3)) S IBCNT=IBCNT+1
- W !?TAB,VAPA($S(IBCONF:16,1:4)),", ",$P($G(^DIC(5,+VAPA($S(IBCONF:17,1:5)),0)),"^",2)," ",$S(IBCONF:$P(VAPA(18),"^",2),1:VAPA(6)) S IBCNT=IBCNT+1
- I $E(IOST,1,2)="C-" D PAUSE^IBOUTL Q:IBQUIT
- ;
- ; -- print main body
- W !! S IBCNT=IBCNT+2
- K ^UTILITY($J,"W"),DIWR,DIWL,DIWF,DN S DIWL=1,DIWF="C80WN"
- S IB=0 F S IB=$O(^IBE(354.6,IBLET,1,IB)) Q:IB="" S X=$G(^(IB,0)) D ^DIWP S IBCNT=IBCNT+1 ; W !,X
- D ^DIWW K ^UTILITY($J,"W")
- I $E(IOST,1,2)="C-" D PAUSE^IBOUTL Q:IBQUIT
- W:$E(IOST,1,2)'="C-" @IOF
- Q
- ;
- FINAL ; -- Print last page
- W @IOF,!!!,?20,"EXEMPTION LETTERS PRINTING COMPLETED"
- W !!,?20,$G(IBCNTL)," LETTERS PRINTED"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEPL 4930 printed Feb 18, 2025@23:33:43 Page 2
- IBARXEPL ;ALB/AAS - PRINT EXEMPTION LETTER - 28-APR-93
- +1 ;;2.0;INTEGRATED BILLING;**34,54,190,206,385**;21-MAR-94;Build 35
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- % IF '$DATA(DT)
- DO DT^DICRW
- +1 IF '$DATA(IOF)
- DO HOME^%ZIS
- +2 WRITE @IOF,"Print Exemption letters to patients"
- +3 KILL ^TMP("IBEX LIST",$JOB)
- +4 SET (IBTEMP,IBADDT,IBOK,IBQUIT)=""
- +5 ;
- +6 ; -- find template
- +7 SET IBTEMP=$ORDER(^DIBT("B","IB EXEMPTION LETTER",0))
- +8 ;
- +9 ; -- use old template or build new one
- +10 WRITE !!!
- +11 ;
- +12 IF IBTEMP
- Begin DoDot:1
- +13 SET DIR(0)="Y"
- SET DIR("A")="Delete Results of Previous Search"
- SET DIR("B")="NO"
- +14 SET DIR("?")="Enter 'Yes' if you would like to delete the results of a previous search, Enter 'No' if you want to keep the results (i.e. you may be reprinting letters from the same list)."
- +15 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET IBQUIT=1
- +16 IF Y=1
- DO DELT
- SET IBTEMP=0
- +17 QUIT
- End DoDot:1
- if IBQUIT
- GOTO END
- +18 ;
- +19 IF 'IBTEMP
- Begin DoDot:1
- +20 SET DIR(0)="Y"
- SET DIR("A")="Store results of Search in Template"
- SET DIR("B")="YES"
- +21 SET DIR("?")="Enter 'Yes' if you would like the results of the search stored in a Sort Template named IB EXEMPTION LETTER. Enter 'No' if you do not want the template created."
- +22 SET DIR("?",1)="Creating the search template will allow you to"
- SET DIR("?",2)="print other lists from the patients you sent the letters to."
- +23 SET DIR("?",3)=" "
- +24 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET IBQUIT=1
- QUIT
- +25 SET IBADD=Y
- +26 QUIT
- End DoDot:1
- if IBQUIT
- GOTO END
- if IBADD
- DO ADDT
- +27 ;
- +28 DO PRINT
- +29 ;
- END IF $DATA(ZTQUEUED)
- QUIT
- +1 DO ^%ZISC
- DO KVAR^VADPT
- +2 KILL C,J,X,Y,D0,DIC,DA,DR,DIE,DFN,DLAYGO,DIR,DIRUT,IB,IBADD,IBADDT,IBTEMP
- +3 KILL IBOK,IBLET,IBCNT,IBCNTL,IBQUIT,IBNAM,IBDATA,IBJ,IBX,TAB,POP,IBALIN
- +4 KILL BY,DHD,DIOEND,FLDS,FR,I,L,TO,VAPA,^TMP("IBEX LIST",$JOB)
- +5 QUIT
- +6 ;
- ADDT ; -- create new template in ^dibt
- +1 KILL DD,DO
- +2 SET DIC="^DIBT("
- SET DIC(0)="L"
- SET X="IB EXEMPTION LETTER"
- SET DIC("DR")="2///NOW;4///354;7///NOW"
- +3 DO FILE^DICN
- SET IBTEMP=+Y
- IF +Y
- SET IBADDT=1
- WRITE !!,"<<< Search Template IB EXEMPTION LETTER created!",!
- +4 QUIT
- +5 ;
- DELT ; -- delete search template
- +1 if $PIECE($GET(^DIBT(+IBTEMP,0)),"^",1)'="IB EXEMPTION LETTER"
- QUIT
- +2 SET DIK="^DIBT("
- SET DA=IBTEMP
- DO ^DIK
- KILL DIK,DA
- +3 WRITE !!,"<<< Search Template IB EXEMPTION LETTER deleted!",!
- +4 SET IBTEMP=""
- +5 QUIT
- +6 ;
- SCR ; -- don't send letters to deceased patients, non-vets, vfa exempt
- +1 ; called by print template IB DO NOT USE
- +2 SET IBOK=0
- NEW IBX
- +3 ; deceased
- IF +$GET(^DPT(D0,.35))
- GOTO SCRQ
- +4 ; patient non-vet
- IF $PIECE($GET(^DPT(D0,"VET")),"^")="N"
- GOTO SCRQ
- +5 SET IBX=$PIECE($GET(^IBE(354.2,+$PIECE($GET(^IBA(354,D0,0)),"^",5),0)),"^",5)
- +6 ;exemption is non-vet
- IF IBX=60
- GOTO SCRQ
- +7 ;sc>50
- IF IBX=10
- GOTO SCRQ
- +8 SET IBOK=1
- SCRQ QUIT
- +1 ;
- PRINT ; -- run through list of letters to PRINT
- +1 SET X="IB NOW EXEMPT"
- SET DIC(0)="XZ"
- SET DIC="^IBE(354.6,"
- DO ^DIC
- SET IBLET=+Y
- +2 if IBLET<1
- QUIT
- +3 ;
- +4 SET DIC="^IBA(354,"
- SET L=0
- SET FLDS="[IB DO NOT USE]"
- SET BY="[IB EXEMPT PATIENTS]"
- SET (FR,TO)="?,?,?"
- SET DHD="@@"
- +5 SET DIOEND="D LET^IBARXEPL"
- +6 DO EN1^DIP
- +7 QUIT
- +8 ;
- LET ; -- called by dioend, prints list from tmp array
- +1 SET IBALIN=$PIECE($GET(^IBE(354.6,IBLET,0)),"^",4)
- +2 IF IBALIN<10!(IBALIN>25)
- SET IBALIN=15
- +3 SET IBNAM=""
- FOR
- SET IBNAM=$ORDER(^TMP("IBEX LIST",$JOB,IBNAM))
- if IBNAM=""!(IBQUIT)
- QUIT
- SET DFN=0
- FOR
- SET DFN=$ORDER(^TMP("IBEX LIST",$JOB,IBNAM,DFN))
- if 'DFN!(IBQUIT)
- QUIT
- SET IBDATA=^(DFN)
- DO ONE
- +4 DO FINAL
- DO END
- +5 QUIT
- +6 ;
- ONE ; -- print one letter
- +1 ; Confidential Address Flag
- NEW IBCONF
- +2 SET TAB=5
- +3 IF '$DATA(IOF)
- DO HOME^%ZIS
- +4 SET IBCNTL=$GET(IBCNTL)+1
- IF $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- +5 SET IB=0
- +6 ;
- +7 ; -- print header
- +8 SET IBCNT=0
- +9 FOR I=1:1:6
- SET IB=$ORDER(^IBE(354.6,IBLET,2,IB))
- if 'IB
- QUIT
- SET X=$GET(^(IB,0))
- WRITE !?(IOM-$LENGTH(X)+1/2),X
- SET IBCNT=IBCNT+1
- +10 WRITE !?TAB
- SET Y=DT
- DO DT^DIQ
- SET IBCNT=IBCNT+1
- +11 FOR IBCNT=IBCNT:1:6
- WRITE !
- SET IBCNT=IBCNT+1
- +12 WRITE !?(IOM-28),"In Reply Refer To:"
- SET IBCNT=IBCNT+1
- +13 WRITE !?(IOM-28),$EXTRACT($PIECE(IBDATA,"^")),$PIECE($PIECE(IBDATA,"^",2),"-",3),!
- +14 SET IBCNT=IBCNT+2
- +15 ; don't print renewal date if they are VFA OK
- +16 SET IBX=$$RXST^IBARXEU(DFN,DT)
- IF $PIECE($GET(^IBE(354.6,IBLET,0)),"^",3)'=2
- IF $PIECE(IBX,"^",3)=120
- SET Y=$$PLUS^IBARXEU0($PIECE(IBX,"^",5))
- IF '$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,$PIECE(IBX,"^",5)))
- WRITE ?(IOM-28),"Renewal Date: "
- DO DT^DIQ
- +17 ;
- +18 ; -- print pt. name and address
- +19 FOR IBCNT=IBCNT:1:(IBALIN-1)
- WRITE !
- +20 WRITE !?TAB,$PIECE(IBNAM,",",2)," ",$PIECE(IBNAM,",")
- DO ADD^VADPT
- SET IBCNT=IBCNT+1
- +21 ; Should we use Confidential Address?
- SET IBCONF=$$CONFADD^IBARXEL()
- +22 WRITE !?TAB,VAPA($SELECT(IBCONF:13,1:1))
- SET IBCNT=IBCNT+1
- +23 IF VAPA($SELECT(IBCONF:14,1:2))'=""
- WRITE !?TAB,VAPA($SELECT(IBCONF:14,1:2))
- IF VAPA($SELECT(IBCONF:15,1:3))'=""
- WRITE ", ",VAPA($SELECT(IBCONF:15,1:3))
- SET IBCNT=IBCNT+1
- +24 WRITE !?TAB,VAPA($SELECT(IBCONF:16,1:4)),", ",$PIECE($GET(^DIC(5,+VAPA($SELECT(IBCONF:17,1:5)),0)),"^",2)," ",$SELECT(IBCONF:$PIECE(VAPA(18),"^",2),1:VAPA(6))
- SET IBCNT=IBCNT+1
- +25 IF $EXTRACT(IOST,1,2)="C-"
- DO PAUSE^IBOUTL
- if IBQUIT
- QUIT
- +26 ;
- +27 ; -- print main body
- +28 WRITE !!
- SET IBCNT=IBCNT+2
- +29 KILL ^UTILITY($JOB,"W"),DIWR,DIWL,DIWF,DN
- SET DIWL=1
- SET DIWF="C80WN"
- +30 ; W !,X
- SET IB=0
- FOR
- SET IB=$ORDER(^IBE(354.6,IBLET,1,IB))
- if IB=""
- QUIT
- SET X=$GET(^(IB,0))
- DO ^DIWP
- SET IBCNT=IBCNT+1
- +31 DO ^DIWW
- KILL ^UTILITY($JOB,"W")
- +32 IF $EXTRACT(IOST,1,2)="C-"
- DO PAUSE^IBOUTL
- if IBQUIT
- QUIT
- +33 if $EXTRACT(IOST,1,2)'="C-"
- WRITE @IOF
- +34 QUIT
- +35 ;
- FINAL ; -- Print last page
- +1 WRITE @IOF,!!!,?20,"EXEMPTION LETTERS PRINTING COMPLETED"
- +2 WRITE !!,?20,$GET(IBCNTL)," LETTERS PRINTED"
- +3 QUIT