- RTRPT5 ;ISC-ALBANY/PKE; management ward location list; 6/1/91
- ;;v 2.0;Record Tracking;**1**;10/22/91
- ;
- S RTPGM="START^RTRPT5",RTVAR="RTBEG^RTEND^DHD^RTAPL" D ZIS^RTUTL Q:POP D START Q
- ;
- START K ^TMP($J) D INIT,SORT,SHOW
- K ^TMP($J),BOR,ABOR,PHON,APHON,PAGE,DATA,NAM,WRD,ONE,POP,LN,EQ,A,B,C,T,Z,E,J
- K RTN,RTDFN,RTADM,RTB,RTDT,RTESC,RTI,RTPGM,RTTY,RTVAR,RT Q
- ;
- SORT F RTDT=RTBEG-.0000001:0 S RTDT=$O(^DGPM("ATT1",RTDT)) Q:('RTDT!(RTDT>RTEND)) D SORT1
- Q
- SORT1 F RTADM=0:0 S RTADM=$O(^DGPM("ATT1",RTDT,RTADM)) Q:'RTADM I $D(^DGPM(RTADM,0)) S Y=^(0),RTDFN=$P(Y,"^",3),WRD=$P(Y,"^",6) I RTDFN,WRD S WRD=$S($D(^DIC(42,WRD,0)):$P(^(0),"^"),1:"") D APL
- Q
- APL Q:WRD']"" S NAM=$S($D(^DPT(RTDFN,0)):^(0),1:"") Q:NAM']"" S RTN=$P(NAM,"^",9),NAM=$P(NAM,"^")
- I $D(^RT("C",RTDFN)) F RT=0:0 S RT=$O(^RT("C",RTDFN,RT)) Q:'RT I $D(^RT(RT,0)),$P(^(0),"^",4)=+RTAPL S RTTY=$P(^(0),"^",3),RTB=$S($D(^("CL")):$P(^("CL"),"^",5),1:"") S ^TMP($J,WRD,NAM,RTN,RT)=RTTY_"^"_RTB
- Q
- SHOW S PAGE=0
- S WRD="" F A=0:0 S WRD=$O(^TMP($J,WRD)) Q:WRD="" D NAM Q:WRD=""
- W !,LN
- Q
- NAM S NAM="" F B=0:0 S NAM=$O(^TMP($J,WRD,NAM)) Q:NAM="" S RTN=$O(^(NAM,0)) D RT Q:WRD=""
- Q
- RT K ONE S RTI="" F C=0:0 S RTI=$O(^TMP($J,WRD,NAM,RTN,RTI)) Q:RTI="" W:$D(ONE) !?70,EQ S DATA=^(RTI) D WRT I RTESC="^" Q
- E W !,LN
- Q
- WRT D BOR,HDR Q:RTESC="^"
- I '$D(ONE) W !,$E(RTN,6,9),?6,NAM,?30,$E(RTN,1,3)_"-"_$E(RTN,4,5)_"-"_$E(RTN,6,99),?45,WRD
- E W !
- W ?70,RTI,?83,$S($D(T(+T)):T(T),1:""),?92,BOR,?116,ABOR,!?92,PHON,?116,APHON S ONE=""
- Q
- HDR I $Y+3<IOSL,PAGE Q
- I PAGE,IOST["C-" S DIR(0)="E" D ^DIR K DIR I 'Y S RTESC="^",(NAM,WRD,RT)="" Q
- S PAGE=PAGE+1 W @IOF K ONE
- W !,LN,!,DHD,?120,"Page: ",PAGE
- W !!?6,"Name",?30,"SSN",?45,"WARD LOCATION",?70,"RECORD #",?83,"TYPE",?92,"CURRENT BORROWER",?112,"ASSOCIATED BORROWER"
- W !,LN
- Q
- BOR S (BOR,ABOR)="",RTB=$P(DATA,"^",2),T=$P(DATA,"^")
- I $D(^RTV(195.9,+RTB,0)) S BOR=^(0)
- S ABOR=$P(BOR,"^",12),PHON=$P(BOR,"^",7),Y=$P(BOR,"^") D NAME^RTB S BOR=$E(Y,1,20)
- I $D(^RTV(195.9,+ABOR,0)) S ABOR=^(0)
- S APHON=$P(ABOR,"^",12),Y=$P(ABOR,"^") D NAME^RTB S ABOR=$E(Y,1,15)
- Q
- INIT F Z=0:0 S Z=$O(^DIC(195.2,"C",+RTAPL,Z)) Q:'Z I $D(^DIC(195.2,Z,0)) S T(Z)=$E($P(^(0),"^"),1,5)
- S EQ="=",LN="-",$P(EQ,"=",132-71)="",$P(LN,"-",131)="",RTESC="" Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTRPT5 2301 printed Feb 19, 2025@00:01:12 Page 2
- RTRPT5 ;ISC-ALBANY/PKE; management ward location list; 6/1/91
- +1 ;;v 2.0;Record Tracking;**1**;10/22/91
- +2 ;
- +3 SET RTPGM="START^RTRPT5"
- SET RTVAR="RTBEG^RTEND^DHD^RTAPL"
- DO ZIS^RTUTL
- if POP
- QUIT
- DO START
- QUIT
- +4 ;
- START KILL ^TMP($JOB)
- DO INIT
- DO SORT
- DO SHOW
- +1 KILL ^TMP($JOB),BOR,ABOR,PHON,APHON,PAGE,DATA,NAM,WRD,ONE,POP,LN,EQ,A,B,C,T,Z,E,J
- +2 KILL RTN,RTDFN,RTADM,RTB,RTDT,RTESC,RTI,RTPGM,RTTY,RTVAR,RT
- QUIT
- +3 ;
- SORT FOR RTDT=RTBEG-.0000001:0
- SET RTDT=$ORDER(^DGPM("ATT1",RTDT))
- if ('RTDT!(RTDT>RTEND))
- QUIT
- DO SORT1
- +1 QUIT
- SORT1 FOR RTADM=0:0
- SET RTADM=$ORDER(^DGPM("ATT1",RTDT,RTADM))
- if 'RTADM
- QUIT
- IF $DATA(^DGPM(RTADM,0))
- SET Y=^(0)
- SET RTDFN=$PIECE(Y,"^",3)
- SET WRD=$PIECE(Y,"^",6)
- IF RTDFN
- IF WRD
- SET WRD=$SELECT($DATA(^DIC(42,WRD,0)):$PIECE(^(0),"^"),1:"")
- DO APL
- +1 QUIT
- APL if WRD']""
- QUIT
- SET NAM=$SELECT($DATA(^DPT(RTDFN,0)):^(0),1:"")
- if NAM']""
- QUIT
- SET RTN=$PIECE(NAM,"^",9)
- SET NAM=$PIECE(NAM,"^")
- +1 IF $DATA(^RT("C",RTDFN))
- FOR RT=0:0
- SET RT=$ORDER(^RT("C",RTDFN,RT))
- if 'RT
- QUIT
- IF $DATA(^RT(RT,0))
- IF $PIECE(^(0),"^",4)=+RTAPL
- SET RTTY=$PIECE(^(0),"^",3)
- SET RTB=$SELECT($DATA(^("CL")):$PIECE(^("CL"),"^",5),1:"")
- SET ^TMP($JOB,WRD,NAM,RTN,RT)=RTTY_"^"_RTB
- +2 QUIT
- SHOW SET PAGE=0
- +1 SET WRD=""
- FOR A=0:0
- SET WRD=$ORDER(^TMP($JOB,WRD))
- if WRD=""
- QUIT
- DO NAM
- if WRD=""
- QUIT
- +2 WRITE !,LN
- +3 QUIT
- NAM SET NAM=""
- FOR B=0:0
- SET NAM=$ORDER(^TMP($JOB,WRD,NAM))
- if NAM=""
- QUIT
- SET RTN=$ORDER(^(NAM,0))
- DO RT
- if WRD=""
- QUIT
- +1 QUIT
- RT KILL ONE
- SET RTI=""
- FOR C=0:0
- SET RTI=$ORDER(^TMP($JOB,WRD,NAM,RTN,RTI))
- if RTI=""
- QUIT
- if $DATA(ONE)
- WRITE !?70,EQ
- SET DATA=^(RTI)
- DO WRT
- IF RTESC="^"
- QUIT
- +1 IF '$TEST
- WRITE !,LN
- +2 QUIT
- WRT DO BOR
- DO HDR
- if RTESC="^"
- QUIT
- +1 IF '$DATA(ONE)
- WRITE !,$EXTRACT(RTN,6,9),?6,NAM,?30,$EXTRACT(RTN,1,3)_"-"_$EXTRACT(RTN,4,5)_"-"_$EXTRACT(RTN,6,99),?45,WRD
- +2 IF '$TEST
- WRITE !
- +3 WRITE ?70,RTI,?83,$SELECT($DATA(T(+T)):T(T),1:""),?92,BOR,?116,ABOR,!?92,PHON,?116,APHON
- SET ONE=""
- +4 QUIT
- HDR IF $Y+3<IOSL
- IF PAGE
- QUIT
- +1 IF PAGE
- IF IOST["C-"
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET RTESC="^"
- SET (NAM,WRD,RT)=""
- QUIT
- +2 SET PAGE=PAGE+1
- WRITE @IOF
- KILL ONE
- +3 WRITE !,LN,!,DHD,?120,"Page: ",PAGE
- +4 WRITE !!?6,"Name",?30,"SSN",?45,"WARD LOCATION",?70,"RECORD #",?83,"TYPE",?92,"CURRENT BORROWER",?112,"ASSOCIATED BORROWER"
- +5 WRITE !,LN
- +6 QUIT
- BOR SET (BOR,ABOR)=""
- SET RTB=$PIECE(DATA,"^",2)
- SET T=$PIECE(DATA,"^")
- +1 IF $DATA(^RTV(195.9,+RTB,0))
- SET BOR=^(0)
- +2 SET ABOR=$PIECE(BOR,"^",12)
- SET PHON=$PIECE(BOR,"^",7)
- SET Y=$PIECE(BOR,"^")
- DO NAME^RTB
- SET BOR=$EXTRACT(Y,1,20)
- +3 IF $DATA(^RTV(195.9,+ABOR,0))
- SET ABOR=^(0)
- +4 SET APHON=$PIECE(ABOR,"^",12)
- SET Y=$PIECE(ABOR,"^")
- DO NAME^RTB
- SET ABOR=$EXTRACT(Y,1,15)
- +5 QUIT
- INIT FOR Z=0:0
- SET Z=$ORDER(^DIC(195.2,"C",+RTAPL,Z))
- if 'Z
- QUIT
- IF $DATA(^DIC(195.2,Z,0))
- SET T(Z)=$EXTRACT($PIECE(^(0),"^"),1,5)
- +1 SET EQ="="
- SET LN="-"
- SET $PIECE(EQ,"=",132-71)=""
- SET $PIECE(LN,"-",131)=""
- SET RTESC=""
- QUIT