- IBOBCR6 ;ALB/RJS-CONTINUOUS PATIENT PRINTOUT;2/20/92
- ;;2.0;INTEGRATED BILLING;**153,183**;21-MAR-94
- ;
- ;
- ;THIS REPORT GATHERS DATA FROM THE IB CONTINUOUS PT FILE 351.1
- ;THE PATIENT FILE 2 AND THE MEANS TEST FILE 41.3 AND REPORTS 6
- ;FIELDS IN COLUMNAR FORMAT. THE FIELDS ARE
- ;Patient Name,Pt-Id,Ward Location,Means Test,Last Means,Eligibility
- ; Status Test Date
- ;
- START ;
- ;***
- ;S XRTL=$ZU(0),XRTN="IBOBCR6-1" D T0^%ZOSV ;start rt clock
- W !,"Margin width of this report is 132 columns",!
- D OPEN G EXIT:POP
- I $D(IO("Q")) D QUEUED,HOME^%ZIS G END
- U IO
- LOOP ;
- ;***
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6" D T1^%ZOSV ;stop rt clock
- ;S XRTL=$ZU(0),XRTN="IBOBCR6-2" D T0^%ZOSV ;start rt clock
- S IBCOL2=23,IBCOL3=37,IBCOL4=54,IBCOL5=66,IBCOL6=84,IBDONE=0,IBRECNR=0
- F S IBRECNR=$O(^IBE(351.1,IBRECNR)) Q:IBRECNR'>0 S IBDATA=^IBE(351.1,IBRECNR,0) D BUILDARY:+IBDATA
- D OUTPUT
- END ;
- ;***
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6-2" D T1^%ZOSV ;stop rt clock
- I $D(ZTQUEUED) S ZTREQ="@" Q
- D ^%ZISC
- EXIT ;
- K IBDATA,IBMNSCAT,IBMNSDTA,IBDATE,IBNAME,IBOUT,IBPAGE,IBPATDIS,POP,IBRECNR
- K IBX,IBXX,Y,DFN,IBCOL2,IBCOL3,IBCOL4,IBCOL5,IBCOL6,IBDONE,^TMP($J,"IBOBCR6"),DIRUT,IBRECORD
- K ZTDESC,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%ZIS,IO("Q")
- D KVAR^VADPT
- ;***
- ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6" D T1^%ZOSV ;stop rt clock
- Q
- QUEUED ;
- S ZTRTN="LOOP^IBOBCR6",ZTDESC="Current Continuous Pt Report"
- D ^%ZTLOAD W !!,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled")
- Q
- BUILDARY ;
- S DFN=+IBDATA,IBPATDIS=$P(IBDATA,"^",2)
- I DFN=""!((IBPATDIS'="")&(IBPATDIS'>DT)) Q
- I '$D(^DPT(DFN,0)) Q
- D 2^VADPT,MEANS,LOADARY
- Q
- MEANS ;
- ;PIECE 2=LAST MT DATE///PIECE 3=STATUS NAME
- S IBXX=$$LST^DGMTU(DFN),IBDATE=$P(IBXX,U,2),IBMNSCAT=$P(IBXX,U,4)
- S IBMNSCAT=$S(IBMNSCAT="P":"PEN",IBMNSCAT="G":"GMT",IBMNSCAT="C":"YES",IBMNSCAT="R":"REQ",1:"NO")
- I IBDATE'="" S IBDATE=$E(IBDATE,4,5)_"/"_$E(IBDATE,6,7)_"/"_$E(IBDATE,2,3)
- Q
- LOADARY ;***IN LOADARY FUNCTION THESE ARE THE VALUES***
- ;*** BEING LOADED FROM THE CALLS TO VADPT ***
- ;
- ; PATIENT = VADM(1)
- ; ELIGIBILITY = $P(VAEL(1),"^",2)
- ; SSI = $P(VADM(2),"^",2)
- ; LOCATION = $G(^DPT(DFN,.1))
- ;
- S ^TMP($J,"IBOBCR6",VADM(1),DFN)=VADM(1)_"^"_$P(VADM(2),"^",2)_"^"_$G(^DPT(DFN,.1))_"^"_$P(VAEL(1),"^",2)_"^"_IBMNSCAT_"^"_IBDATE
- Q
- OUTPUT ;
- S Y=DT X ^DD("DD")
- S IBPAGE=1,IBOUT=""
- D HEADING
- S IBNAME=""
- F S IBNAME=$O(^TMP($J,"IBOBCR6",IBNAME)) Q:IBNAME=""!(IBDONE) S DFN="" F S DFN=$O(^TMP($J,"IBOBCR6",IBNAME,DFN)) Q:DFN=""!(IBDONE) D LINE
- Q
- LINE ;
- S IBRECORD=^TMP($J,"IBOBCR6",IBNAME,DFN)
- ;***PATIENT NAME***
- W $E(IBNAME,1,20),?IBCOL2
- ;***PATIENT SSI****
- W $E($P(IBRECORD,"^",2),1,11),?IBCOL3
- ;***PATIENT LOCATION***
- W $E($P(IBRECORD,"^",3),1,14),?IBCOL4
- ;***LAST MEANS TEST DATE****
- W $E($P(IBRECORD,"^",6),1,8),?IBCOL5
- ;***PATIENT MEANS TEST STATUS***
- W $P(IBRECORD,"^",5),?IBCOL6
- ;***PATIENT ELIGIBILITY***
- W $E($P(IBRECORD,"^",4),1,30),!
- D:$Y+3>IOSL HEADING
- Q
- OPEN ;
- S %ZIS="QM" D ^%ZIS
- Q
- HEADING ;
- I IBPAGE>1,($E(IOST,1,2)="C-")
- I S DIR(0)="E" D ^DIR K DIR I $D(DUOUT) S IBDONE=1 Q
- I $E(IOST,1,2)["C-"!(IBPAGE>1) W @IOF ; initial form feeds to crts subsequent form feeds to all
- W !,Y,?IBCOL2,"***Patients Continuously Hospitalized Since July 1, 1986***",?IBCOL6,"PAGE ",IBPAGE
- W !!,"Patient NAME",?IBCOL2,"Pt-Id",?IBCOL3,"Ward Location",?IBCOL4
- W "Last Means",?IBCOL5,"Means Test",?IBCOL6,"Eligibility"
- W !,?IBCOL4,"Test Date",?IBCOL5,"Status",!
- S IBX="",$P(IBX,"=",IOM)="" W IBX,!
- S IBPAGE=IBPAGE+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBOBCR6 3646 printed Feb 18, 2025@23:51:45 Page 2
- IBOBCR6 ;ALB/RJS-CONTINUOUS PATIENT PRINTOUT;2/20/92
- +1 ;;2.0;INTEGRATED BILLING;**153,183**;21-MAR-94
- +2 ;
- +3 ;
- +4 ;THIS REPORT GATHERS DATA FROM THE IB CONTINUOUS PT FILE 351.1
- +5 ;THE PATIENT FILE 2 AND THE MEANS TEST FILE 41.3 AND REPORTS 6
- +6 ;FIELDS IN COLUMNAR FORMAT. THE FIELDS ARE
- +7 ;Patient Name,Pt-Id,Ward Location,Means Test,Last Means,Eligibility
- +8 ; Status Test Date
- +9 ;
- START ;
- +1 ;***
- +2 ;S XRTL=$ZU(0),XRTN="IBOBCR6-1" D T0^%ZOSV ;start rt clock
- +3 WRITE !,"Margin width of this report is 132 columns",!
- +4 DO OPEN
- if POP
- GOTO EXIT
- +5 IF $DATA(IO("Q"))
- DO QUEUED
- DO HOME^%ZIS
- GOTO END
- +6 USE IO
- LOOP ;
- +1 ;***
- +2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6" D T1^%ZOSV ;stop rt clock
- +3 ;S XRTL=$ZU(0),XRTN="IBOBCR6-2" D T0^%ZOSV ;start rt clock
- +4 SET IBCOL2=23
- SET IBCOL3=37
- SET IBCOL4=54
- SET IBCOL5=66
- SET IBCOL6=84
- SET IBDONE=0
- SET IBRECNR=0
- +5 FOR
- SET IBRECNR=$ORDER(^IBE(351.1,IBRECNR))
- if IBRECNR'>0
- QUIT
- SET IBDATA=^IBE(351.1,IBRECNR,0)
- if +IBDATA
- DO BUILDARY
- +6 DO OUTPUT
- END ;
- +1 ;***
- +2 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6-2" D T1^%ZOSV ;stop rt clock
- +3 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- QUIT
- +4 DO ^%ZISC
- EXIT ;
- +1 KILL IBDATA,IBMNSCAT,IBMNSDTA,IBDATE,IBNAME,IBOUT,IBPAGE,IBPATDIS,POP,IBRECNR
- +2 KILL IBX,IBXX,Y,DFN,IBCOL2,IBCOL3,IBCOL4,IBCOL5,IBCOL6,IBDONE,^TMP($JOB,"IBOBCR6"),DIRUT,IBRECORD
- +3 KILL ZTDESC,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,%ZIS,IO("Q")
- +4 DO KVAR^VADPT
- +5 ;***
- +6 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOBCR6" D T1^%ZOSV ;stop rt clock
- +7 QUIT
- QUEUED ;
- +1 SET ZTRTN="LOOP^IBOBCR6"
- SET ZTDESC="Current Continuous Pt Report"
- +2 DO ^%ZTLOAD
- WRITE !!,$SELECT($DATA(ZTSK):"Request Queued!",1:"Request Cancelled")
- +3 QUIT
- BUILDARY ;
- +1 SET DFN=+IBDATA
- SET IBPATDIS=$PIECE(IBDATA,"^",2)
- +2 IF DFN=""!((IBPATDIS'="")&(IBPATDIS'>DT))
- QUIT
- +3 IF '$DATA(^DPT(DFN,0))
- QUIT
- +4 DO 2^VADPT
- DO MEANS
- DO LOADARY
- +5 QUIT
- MEANS ;
- +1 ;PIECE 2=LAST MT DATE///PIECE 3=STATUS NAME
- +2 SET IBXX=$$LST^DGMTU(DFN)
- SET IBDATE=$PIECE(IBXX,U,2)
- SET IBMNSCAT=$PIECE(IBXX,U,4)
- +3 SET IBMNSCAT=$SELECT(IBMNSCAT="P":"PEN",IBMNSCAT="G":"GMT",IBMNSCAT="C":"YES",IBMNSCAT="R":"REQ",1:"NO")
- +4 IF IBDATE'=""
- SET IBDATE=$EXTRACT(IBDATE,4,5)_"/"_$EXTRACT(IBDATE,6,7)_"/"_$EXTRACT(IBDATE,2,3)
- +5 QUIT
- LOADARY ;***IN LOADARY FUNCTION THESE ARE THE VALUES***
- +1 ;*** BEING LOADED FROM THE CALLS TO VADPT ***
- +2 ;
- +3 ; PATIENT = VADM(1)
- +4 ; ELIGIBILITY = $P(VAEL(1),"^",2)
- +5 ; SSI = $P(VADM(2),"^",2)
- +6 ; LOCATION = $G(^DPT(DFN,.1))
- +7 ;
- +8 SET ^TMP($JOB,"IBOBCR6",VADM(1),DFN)=VADM(1)_"^"_$PIECE(VADM(2),"^",2)_"^"_$GET(^DPT(DFN,.1))_"^"_$PIECE(VAEL(1),"^",2)_"^"_IBMNSCAT_"^"_IBDATE
- +9 QUIT
- OUTPUT ;
- +1 SET Y=DT
- XECUTE ^DD("DD")
- +2 SET IBPAGE=1
- SET IBOUT=""
- +3 DO HEADING
- +4 SET IBNAME=""
- +5 FOR
- SET IBNAME=$ORDER(^TMP($JOB,"IBOBCR6",IBNAME))
- if IBNAME=""!(IBDONE)
- QUIT
- SET DFN=""
- FOR
- SET DFN=$ORDER(^TMP($JOB,"IBOBCR6",IBNAME,DFN))
- if DFN=""!(IBDONE)
- QUIT
- DO LINE
- +6 QUIT
- LINE ;
- +1 SET IBRECORD=^TMP($JOB,"IBOBCR6",IBNAME,DFN)
- +2 ;***PATIENT NAME***
- +3 WRITE $EXTRACT(IBNAME,1,20),?IBCOL2
- +4 ;***PATIENT SSI****
- +5 WRITE $EXTRACT($PIECE(IBRECORD,"^",2),1,11),?IBCOL3
- +6 ;***PATIENT LOCATION***
- +7 WRITE $EXTRACT($PIECE(IBRECORD,"^",3),1,14),?IBCOL4
- +8 ;***LAST MEANS TEST DATE****
- +9 WRITE $EXTRACT($PIECE(IBRECORD,"^",6),1,8),?IBCOL5
- +10 ;***PATIENT MEANS TEST STATUS***
- +11 WRITE $PIECE(IBRECORD,"^",5),?IBCOL6
- +12 ;***PATIENT ELIGIBILITY***
- +13 WRITE $EXTRACT($PIECE(IBRECORD,"^",4),1,30),!
- +14 if $Y+3>IOSL
- DO HEADING
- +15 QUIT
- OPEN ;
- +1 SET %ZIS="QM"
- DO ^%ZIS
- +2 QUIT
- HEADING ;
- +1 IF IBPAGE>1
- IF ($EXTRACT(IOST,1,2)="C-")
- +2 IF $TEST
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF $DATA(DUOUT)
- SET IBDONE=1
- QUIT
- +3 ; initial form feeds to crts subsequent form feeds to all
- IF $EXTRACT(IOST,1,2)["C-"!(IBPAGE>1)
- WRITE @IOF
- +4 WRITE !,Y,?IBCOL2,"***Patients Continuously Hospitalized Since July 1, 1986***",?IBCOL6,"PAGE ",IBPAGE
- +5 WRITE !!,"Patient NAME",?IBCOL2,"Pt-Id",?IBCOL3,"Ward Location",?IBCOL4
- +6 WRITE "Last Means",?IBCOL5,"Means Test",?IBCOL6,"Eligibility"
- +7 WRITE !,?IBCOL4,"Test Date",?IBCOL5,"Status",!
- +8 SET IBX=""
- SET $PIECE(IBX,"=",IOM)=""
- WRITE IBX,!
- +9 SET IBPAGE=IBPAGE+1
- +10 QUIT