- IBERS2 ;ALB/ARH - APPOINTMENT CHECK-OFF SHEET GENERATOR (CONTINUED) ; 12/6/91
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;gather the data for an individual patient appointment check-off sheet (all data needed is passed in, in IBLN)
- S IBLC=0,IBDT=$P(IBLN,"^",9),DFN=$P(IBLN,"^",1) D ELIG^VADPT
- S IBX="AMBULATORY SURGERY CHECK-OFF SHEET",IBW=1 D LINE S IBX="" D ENDLN
- PAT ;name,clinic,appointment date/time
- S IBX=" Patient Name: "_$P(IBLN,"^",3),IBY=$J("",15)_"Clinic: "_$P(IBLN,"^",5),IBW=2 D LINE
- S IBX=" Patient Id: "_$P(IBLN,"^",8),IBY="Appointment Date/Time: "_$P(IBLN,"^",4),IBW=2 D LINE
- S IBX="",IBY=" Appointment Type: "_$P(IBLN,"^",7),IBW=2 D LINE
- S IBX=IBDSH D ENDLN
- ;
- MT ;means test, date of last means test, primary eligibility
- S Y=$$LST^DGMTU(DFN,IBDT)
- S IBX=" Means Test: "_$P(Y,"^",3),IBY=" Primary Eligibility: "_$P(VAEL(1),"^",2),IBW=2 D LINE
- S Y=$P(Y,"^",2) X ^DD("DD")
- S IBX="Last Means Test: "_Y,IBY=" Service Connected: "_$S(+VAEL(3):$P(VAEL(3),"^",2)_"%",1:"NO"),IBW=2 D LINE
- S IBX=IBDSH D ENDLN
- ;
- ;find active insurance companies and SC disabilities
- INS S IBCOND=0,IBINDT=IBDT,IBOUTP=1 D ^IBCNS
- S IBX=" Insurance: " I 'IBINS S IBINS(1)=IBX_"None Active" G SC
- S ^TMP("IBRSP",$J,1)=$E(^TMP("IBRSP",$J,1),1,(IOM-4))_$J("INS",(IOM-4-$L(^TMP("IBRSP",$J,1))))
- ;S $E(^TMP("IBRSP",$J,1),(IOM-3),IOM)="INS"
- I $D(IBDD) S IBNS="",IBI=1 F S IBNS=$O(IBDD(IBNS)) Q:IBNS="" D
- . S IBLX=$G(IBINS(IBI)),IBCMP=$P($G(^DIC(36,+IBNS,0)),"^",1)
- . I IBLX="" S IBINS(IBI)=IBX_IBCMP,IBX=$J("",17) Q
- . I IB2>($L(IBLX)+$L(IBCMP)+2) S IBINS(IBI)=IBLX_", "_IBCMP Q
- . S IBI=IBI+1 S IBINS(IBI)=IBX_IBCMP,IBX=$J("",17)
- SC G:'+VAEL(3)&('$D(^DPT(DFN,.372))) ENDINSC
- S IBX=" SC Disabilities: "
- I 'VAEL(4),$S($P($G(^DG(391,+VAEL(6),0)),"^",2):0,1:1) S IBSCD(1)=IBX_"Not A Veteran" G ENDINSC
- I '$D(^DPT(DFN,.372)) S IBSCD(1)=IBX_"No SC Disabilities Listed" G ENDINSC
- I '$O(^DPT(DFN,.372,0)) S IBSCD(1)=IBX_"None Stated" G ENDINSC
- S (IBCOND,IBSC)=0 F S IBSC=$O(^DPT(DFN,.372,IBSC)) Q:IBSC="" D
- . S IBDIS=$G(^DPT(DFN,.372,IBSC,0)) Q:'$P(IBDIS,"^",3) S IBDISC=$G(^DIC(31,+IBDIS,0)),IBCOND=IBCOND+1
- . S IBSCD(IBCOND)=IBX_IBCOND_" "_$E($S($P(IBDISC,"^",4)'="":$P(IBDISC,"^",4),1:$P(IBDISC,"^",1)),1,(IB2-$S(IBCOND>9:31,1:30)))_$J($P(IBDIS,"^",2),4)_"%"
- . S IBX=$J("",23)
- I 'IBCOND S IBSCD(1)=IBX_"None"
- ENDINSC ;print the INS and SC arrays on the same lines
- F IBI=1:1 Q:'$D(IBINS(IBI))&'$D(IBSCD(IBI)) S IBX=$G(IBINS(IBI)),IBY=$G(IBSCD(IBI)),IBW=2 D LINE
- S IBX=IBDSH D ENDLN
- K IBLX,IBCMP,IBINS,IBSCD,IBNS,IBDIS,IBDISC,IBSC,IBI,IBINDT,IBINS,IBOUTP,IBDD,VAEL,VAERR
- ;
- DX ;print discharge and billing dx's for last 6 appointments
- ;D ^IBERS3
- ;
- CHECKS ;print space for checks
- S IBZ=IB3\2,IBX=$J("EKG ( )",IBZ+5),IBY=$J("LAB ( )",IBZ+5),IBZ=$J("X-RAY ( )",IBZ+6),IBW=3 D LINE
- S IBX=IBDSH D ENDLN
- ;
- END ;end of sheet, Last section on patient printed on RS: new dx's, signature
- I IBCOND S IBX=$J("",IB1)_"Visit for SC condition: 1" F IBI=2:1:IBCOND S IBX=IBX_", "_IBI
- D:IBCOND ENDLN
- S IBX="Diagnosis: ",IBY="Signature: ",IBW=2 D LINE
- S IBX=IBDSH D ENDLN S IBX="" D ENDLN
- ;
- EXIT K IBDT,IBLC,IBI,IBX,IBY,IBZ,IBW,IBCOND,DFN,X,Y
- Q
- ;
- LINE ;prints 1 (IBW=1) 2 (IBW=2) or three (IBW=3) pieces of data on a formated line
- ;(IBX, IBY, IBZ should contain the 1st, 2nd, and 3rd piece of data, respectively)
- ;use IBW=1 for headers centered on the page: IBX=header text
- ;entry at lable ENDLN can be used to insert a line with no additional frmating
- I IBW=1 S IBT=IB1+(IB2-($L(IBX)/2)),IBX=$J("",IBT)_IBX G ENDLN
- S IBL=$S(IBW=2:IB2,1:IB3),IBT=IB4
- S IBX=$E(IBX,1,IBL),IBX=$J("",IB1)_IBX_$J("",(IBL-$L(IBX)))
- S IBY=$E(IBY,1,IBL),IBX=IBX_$J("",IBT)_IBY_$J("",(IBL-$L(IBY)))
- I IBW=3 S IBZ=$E(IBZ,1,IBL),IBX=IBX_$J("",IBT)_IBZ_$J("",(IBL-$L(IBZ)))
- ENDLN S IBLC=IBLC+1,^TMP("IBRSP",$J,IBLC)=IBX
- K IBT,IBL
- Q
- IBERS2 ;ALB/ARH - APPOINTMENT CHECK-OFF SHEET GENERATOR (CONTINUED) ; 12/6/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 ;gather the data for an individual patient appointment check-off sheet (all data needed is passed in, in IBLN)
- +5 SET IBLC=0
- SET IBDT=$PIECE(IBLN,"^",9)
- SET DFN=$PIECE(IBLN,"^",1)
- DO ELIG^VADPT
- +6 SET IBX="AMBULATORY SURGERY CHECK-OFF SHEET"
- SET IBW=1
- DO LINE
- SET IBX=""
- DO ENDLN
- PAT ;name,clinic,appointment date/time
- +1 SET IBX=" Patient Name: "_$PIECE(IBLN,"^",3)
- SET IBY=$JUSTIFY("",15)_"Clinic: "_$PIECE(IBLN,"^",5)
- SET IBW=2
- DO LINE
- +2 SET IBX=" Patient Id: "_$PIECE(IBLN,"^",8)
- SET IBY="Appointment Date/Time: "_$PIECE(IBLN,"^",4)
- SET IBW=2
- DO LINE
- +3 SET IBX=""
- SET IBY=" Appointment Type: "_$PIECE(IBLN,"^",7)
- SET IBW=2
- DO LINE
- +4 SET IBX=IBDSH
- DO ENDLN
- +5 ;
- MT ;means test, date of last means test, primary eligibility
- +1 SET Y=$$LST^DGMTU(DFN,IBDT)
- +2 SET IBX=" Means Test: "_$PIECE(Y,"^",3)
- SET IBY=" Primary Eligibility: "_$PIECE(VAEL(1),"^",2)
- SET IBW=2
- DO LINE
- +3 SET Y=$PIECE(Y,"^",2)
- XECUTE ^DD("DD")
- +4 SET IBX="Last Means Test: "_Y
- SET IBY=" Service Connected: "_$SELECT(+VAEL(3):$PIECE(VAEL(3),"^",2)_"%",1:"NO")
- SET IBW=2
- DO LINE
- +5 SET IBX=IBDSH
- DO ENDLN
- +6 ;
- +7 ;find active insurance companies and SC disabilities
- INS SET IBCOND=0
- SET IBINDT=IBDT
- SET IBOUTP=1
- DO ^IBCNS
- +1 SET IBX=" Insurance: "
- IF 'IBINS
- SET IBINS(1)=IBX_"None Active"
- GOTO SC
- +2 SET ^TMP("IBRSP",$JOB,1)=$EXTRACT(^TMP("IBRSP",$JOB,1),1,(IOM-4))_$JUSTIFY("INS",(IOM-4-$LENGTH(^TMP("IBRSP",$JOB,1))))
- +3 ;S $E(^TMP("IBRSP",$J,1),(IOM-3),IOM)="INS"
- +4 IF $DATA(IBDD)
- SET IBNS=""
- SET IBI=1
- FOR
- SET IBNS=$ORDER(IBDD(IBNS))
- IF IBNS=""
- QUIT
- Begin DoDot:1
- +5 SET IBLX=$GET(IBINS(IBI))
- SET IBCMP=$PIECE($GET(^DIC(36,+IBNS,0)),"^",1)
- +6 IF IBLX=""
- SET IBINS(IBI)=IBX_IBCMP
- SET IBX=$JUSTIFY("",17)
- QUIT
- +7 IF IB2>($LENGTH(IBLX)+$LENGTH(IBCMP)+2)
- SET IBINS(IBI)=IBLX_", "_IBCMP
- QUIT
- +8 SET IBI=IBI+1
- SET IBINS(IBI)=IBX_IBCMP
- SET IBX=$JUSTIFY("",17)
- End DoDot:1
- SC IF '+VAEL(3)&('$DATA(^DPT(DFN,.372)))
- GOTO ENDINSC
- +1 SET IBX=" SC Disabilities: "
- +2 IF 'VAEL(4)
- IF $SELECT($PIECE($GET(^DG(391,+VAEL(6),0)),"^",2):0,1:1)
- SET IBSCD(1)=IBX_"Not A Veteran"
- GOTO ENDINSC
- +3 IF '$DATA(^DPT(DFN,.372))
- SET IBSCD(1)=IBX_"No SC Disabilities Listed"
- GOTO ENDINSC
- +4 IF '$ORDER(^DPT(DFN,.372,0))
- SET IBSCD(1)=IBX_"None Stated"
- GOTO ENDINSC
- +5 SET (IBCOND,IBSC)=0
- FOR
- SET IBSC=$ORDER(^DPT(DFN,.372,IBSC))
- IF IBSC=""
- QUIT
- Begin DoDot:1
- +6 SET IBDIS=$GET(^DPT(DFN,.372,IBSC,0))
- IF '$PIECE(IBDIS,"^",3)
- QUIT
- SET IBDISC=$GET(^DIC(31,+IBDIS,0))
- SET IBCOND=IBCOND+1
- +7 SET IBSCD(IBCOND)=IBX_IBCOND_" "_$EXTRACT($SELECT($PIECE(IBDISC,"^",4)'="":$PIECE(IBDISC,"^",4),1:$PIECE(IBDISC,"^",1)),1,(IB2-$SELECT(IBCOND>9:31,1:30)))_$JUSTIFY($PIECE(IBDIS,"^",2),4)_"%"
- +8 SET IBX=$JUSTIFY("",23)
- End DoDot:1
- +9 IF 'IBCOND
- SET IBSCD(1)=IBX_"None"
- ENDINSC ;print the INS and SC arrays on the same lines
- +1 FOR IBI=1:1
- IF '$DATA(IBINS(IBI))&'$DATA(IBSCD(IBI))
- QUIT
- SET IBX=$GET(IBINS(IBI))
- SET IBY=$GET(IBSCD(IBI))
- SET IBW=2
- DO LINE
- +2 SET IBX=IBDSH
- DO ENDLN
- +3 KILL IBLX,IBCMP,IBINS,IBSCD,IBNS,IBDIS,IBDISC,IBSC,IBI,IBINDT,IBINS,IBOUTP,IBDD,VAEL,VAERR
- +4 ;
- DX ;print discharge and billing dx's for last 6 appointments
- +1 ;D ^IBERS3
- +2 ;
- CHECKS ;print space for checks
- +1 SET IBZ=IB3\2
- SET IBX=$JUSTIFY("EKG ( )",IBZ+5)
- SET IBY=$JUSTIFY("LAB ( )",IBZ+5)
- SET IBZ=$JUSTIFY("X-RAY ( )",IBZ+6)
- SET IBW=3
- DO LINE
- +2 SET IBX=IBDSH
- DO ENDLN
- +3 ;
- END ;end of sheet, Last section on patient printed on RS: new dx's, signature
- +1 IF IBCOND
- SET IBX=$JUSTIFY("",IB1)_"Visit for SC condition: 1"
- FOR IBI=2:1:IBCOND
- SET IBX=IBX_", "_IBI
- +2 IF IBCOND
- DO ENDLN
- +3 SET IBX="Diagnosis: "
- SET IBY="Signature: "
- SET IBW=2
- DO LINE
- +4 SET IBX=IBDSH
- DO ENDLN
- SET IBX=""
- DO ENDLN
- +5 ;
- EXIT KILL IBDT,IBLC,IBI,IBX,IBY,IBZ,IBW,IBCOND,DFN,X,Y
- +1 QUIT
- +2 ;
- LINE ;prints 1 (IBW=1) 2 (IBW=2) or three (IBW=3) pieces of data on a formated line
- +1 ;(IBX, IBY, IBZ should contain the 1st, 2nd, and 3rd piece of data, respectively)
- +2 ;use IBW=1 for headers centered on the page: IBX=header text
- +3 ;entry at lable ENDLN can be used to insert a line with no additional frmating
- +4 IF IBW=1
- SET IBT=IB1+(IB2-($LENGTH(IBX)/2))
- SET IBX=$JUSTIFY("",IBT)_IBX
- GOTO ENDLN
- +5 SET IBL=$SELECT(IBW=2:IB2,1:IB3)
- SET IBT=IB4
- +6 SET IBX=$EXTRACT(IBX,1,IBL)
- SET IBX=$JUSTIFY("",IB1)_IBX_$JUSTIFY("",(IBL-$LENGTH(IBX)))
- +7 SET IBY=$EXTRACT(IBY,1,IBL)
- SET IBX=IBX_$JUSTIFY("",IBT)_IBY_$JUSTIFY("",(IBL-$LENGTH(IBY)))
- +8 IF IBW=3
- SET IBZ=$EXTRACT(IBZ,1,IBL)
- SET IBX=IBX_$JUSTIFY("",IBT)_IBZ_$JUSTIFY("",(IBL-$LENGTH(IBZ)))
- ENDLN SET IBLC=IBLC+1
- SET ^TMP("IBRSP",$JOB,IBLC)=IBX
- +1 KILL IBT,IBL
- +2 QUIT
