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
