A1B2Q ;JLU/ALB; National inquiry of patients; 1/13/90
;;Version 1.55 (local for MAS v5 sites);;
ADD W !!,"Address:"
I A1B2A1'="" W ?9,A1B2A1,!
I A1B2A2'="" W ?9,A1B2A2,!
I A1B2A3'="" W ?9,A1B2A3,!
W ?9,$S(A1B2A4'="":A1B2A4,1:"")," ",$S(A1B2A5'="":A1B2A5,1:"")," ",$S(A1B2A6'="":A1B2A6,1:"")
Q
PG D HOME^%ZIS W @IOF
Q
;
ST ;For end of screen.
S DIR(0)="E" D ^DIR S A1B2E=Y
I A1B2E D PG
Q
;
B ;Entry point for inquiry display.
S A1B2X=^A1B2(11500.1,A1B2Y,0)
I $D(^A1B2(11500.1,A1B2Y,.11)) S A1B2X1=^(.11),A1B2A1=$P(A1B2X1,U,1),A1B2A2=$P(A1B2X1,U,2),A1B2A3=$P(A1B2X1,U,3),A1B2A4=$P(A1B2X1,U,4),A1B2A5=$S($P(A1B2X1,U,5):$P(^DIC(5,$P(A1B2X1,U,5),0),U),1:""),A1B2A6=$P(A1B2X1,U,6)
S A1B2SS=$P(A1B2X,U),A1B2NA=$P(A1B2X,U,2),A1B2DB=$P(A1B2X,U,3),A1B2BS=$P(A1B2X,U,4),A1B2RA=$P(A1B2X,U,5),A1B2CD=$S($P(A1B2X,U,7)="S":"Seriously Ill",1:"")
I A1B2RA S A1B2RA=$P(^DIC(25002.1,A1B2RA,0),U)
I A1B2DB S (X2,Y)=A1B2DB D DD^%DT S A1B2DB=Y,X1=DT D ^%DTC S A1B2AG=X\365.25
I A1B2BS S A1B2BS=$P(^DIC(23,A1B2BS,0),U)
F A1B2LP=0:0 S A1B2LP=$O(^A1B2(11500.2,"C",A1B2Y,A1B2LP)) Q:'A1B2LP S Y1=^A1B2(11500.2,A1B2LP,0) I $P(Y1,U,15) D AD
F A1B2LP=0:0 S A1B2LP=$O(^A1B2(11500.4,"C",A1B2Y,A1B2LP)) Q:'A1B2LP S Y1=^A1B2(11500.4,A1B2LP,0) I $P(Y1,U,15) D RD
Q
;
AD S A1B2AS=$P(Y1,U,3)
;FAC^DT AD^AD SP^DC DT^DC SP^TRAN TO^TRAN TY
S X=U_+Y1_U_$S(A1B2AS:$P(^DIC(42.4,A1B2AS,0),U),1:"")_U_$P(Y1,U,6)_U_$S($P(Y1,U,5):$P(^DG(405.2,$P(Y1,U,5),0),U),1:"")_U_$P(Y1,U,10)_U_$P(Y1,U,11)
X ^DD("FUNC",14,1) S $P(X,U)=$P(Y1,U,8),A1B2AD(9999999-+Y1)=X
Q
;
RD S A1B2DP=$P(Y1,U,5)
S X=U_+Y1_U_$S(A1B2DP:$P(^DIC(37,A1B2DP,0),U),1:"")
X ^DD("FUNC",14,1) S $P(X,U)=$P(Y1,U,8),A1B2RD(9999999-+Y1)=X
Q
;
C ;Entry point for display.
D PG,HD1
W !!,"Patient: ",A1B2NA I A1B2CD'="",$S('$D(A1B2NTY):1,1:$P(A1B2NTY,U,3)) W ?45,"*** ",A1B2CD," ***"
W !,?4,"SSN: ",A1B2SS,?41,"Service Branch: ",$E(A1B2BS,1,23)
W !,?4,"DOB: ",A1B2DB,?51,"Rank: ",A1B2RA
W !,?4,"Age: ",$S($D(A1B2AG):A1B2AG,1:"")
I $D(A1B2NTY),$D(A1B2X1) D ADD
;Came from A1B2ZUTL to display
I $D(A1B2ZU) D EX Q
S A1B2L="- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - "
S A1B2E=1
I $D(A1B2AD) W !,A1B2L F A1B2LP=0:0 S A1B2LP=$O(A1B2AD(A1B2LP)) Q:'A1B2LP D:$Y>(IOSL-5) ST Q:'A1B2E D WA
I $D(A1B2RD) W !!,A1B2L F A1B2LP=0:0 S A1B2LP=$O(A1B2RD(A1B2LP)) Q:'A1B2LP D:$Y>(IOSL-5) ST Q:'A1B2E D WR
W !!!
Q
;
WA W !!,"Admitted to ",$S($L($P(A1B2AD(A1B2LP),U))>2:$E($P(A1B2AD(A1B2LP),U),1,26),1:"UNKNOWN")," on "
S Y=$P(A1B2AD(A1B2LP),U,2) D DT^DIO2 W " to ",$P(A1B2AD(A1B2LP),U,3)
I $L($P(A1B2AD(A1B2LP),U,4))>2 W !," Discharged from ",$S($L($P(A1B2AD(A1B2LP),U))>2:$E($P(A1B2AD(A1B2LP),U),1,26),1:"UNKNOWN")," on "
I $L($P(A1B2AD(A1B2LP),U,4))>2 S Y=$P(A1B2AD(A1B2LP),U,4) D DT^DIO2 W " for ",$P(A1B2AD(A1B2LP),U,5)
I $L($P(A1B2AD(A1B2LP),U,6))>2 W !," Transferred to ",$P(A1B2AD(A1B2LP),U,6),$S($P(A1B2AD(A1B2LP),U,7)=0:" (VAMC)",1:" (UNKNOWN)")
Q
;
WR W !!,"Registered at ",$S($L($P(A1B2RD(A1B2LP),U))>2:$E($P(A1B2RD(A1B2LP),U),1,26),1:"UNKNOWN")," on "
S Y=$P(A1B2RD(A1B2LP),U,2) D DT^DIO2 W " for ",$P(A1B2RD(A1B2LP),U,3)
Q
;
HD1 ;Header for inquiry report.
W !,?25,"*** ODS Patient Inquiry ***"
;;;W !,"------------------------------------------------------------------------------"
Q
;
EX ;Kill point.
K DIC,A1B2X,A1B2SS,A1B2NA,A1B2DB,A1B2BS,A1B2AD,A1B2RD,A1B2DP,A1B2AS,Y,A1B2LP,A1B2Y,A1B2E,A1B2RA,DIR,Y1,A1B2CD,A1B2Y3,Y2,Y3,A1B2A1,A1B2A2,A1B2A3,A1B2A4,A1B2A5,A1B2A6,A1B2X1,X,A1B2L,A1B2AG
Q
;
A ;Entry point for inquiry lookup.
S DIC="^A1B2(11500.1,",DIC(0)="AEMQ",DIC("A")="Select Patient: "
S DIC("S")="I $P(^(0),U,8)=1 N X S X=$S($D(A1B2NTY):$P(A1B2NTY,U,2),1:"""") I $S(X=""""!(X=""A""):1,X=""V"":$D(^A1B2(11500.1,+Y,""NET"",""B"",+A1B2FN))>9,X=""R"":$D(^A1B2(11500.1,+Y,""NET"",""AR"",+A1B2VRG))>9,1:0)"
D ^DIC K DIC I 'Y!(Y<0) Q
S A1B2Y=+Y
D B,C,EX G A
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HA1B2Q 3951 printed Nov 22, 2024@17:31:27 Page 2
A1B2Q ;JLU/ALB; National inquiry of patients; 1/13/90
+1 ;;Version 1.55 (local for MAS v5 sites);;
ADD WRITE !!,"Address:"
+1 IF A1B2A1'=""
WRITE ?9,A1B2A1,!
+2 IF A1B2A2'=""
WRITE ?9,A1B2A2,!
+3 IF A1B2A3'=""
WRITE ?9,A1B2A3,!
+4 WRITE ?9,$SELECT(A1B2A4'="":A1B2A4,1:"")," ",$SELECT(A1B2A5'="":A1B2A5,1:"")," ",$SELECT(A1B2A6'="":A1B2A6,1:"")
+5 QUIT
PG DO HOME^%ZIS
WRITE @IOF
+1 QUIT
+2 ;
ST ;For end of screen.
+1 SET DIR(0)="E"
DO ^DIR
SET A1B2E=Y
+2 IF A1B2E
DO PG
+3 QUIT
+4 ;
B ;Entry point for inquiry display.
+1 SET A1B2X=^A1B2(11500.1,A1B2Y,0)
+2 IF $DATA(^A1B2(11500.1,A1B2Y,.11))
SET A1B2X1=^(.11)
SET A1B2A1=$PIECE(A1B2X1,U,1)
SET A1B2A2=$PIECE(A1B2X1,U,2)
SET A1B2A3=$PIECE(A1B2X1,U,3)
SET A1B2A4=$PIECE(A1B2X1,U,4)
SET A1B2A5=$SELECT($PIECE(A1B2X1,U,5):$PIECE(^DIC(5,$PIECE(A1B2X1,U,5),0),U),1:"")
SET A1B2A6=$PIECE(A1B2X1,U,6)
+3 SET A1B2SS=$PIECE(A1B2X,U)
SET A1B2NA=$PIECE(A1B2X,U,2)
SET A1B2DB=$PIECE(A1B2X,U,3)
SET A1B2BS=$PIECE(A1B2X,U,4)
SET A1B2RA=$PIECE(A1B2X,U,5)
SET A1B2CD=$SELECT($PIECE(A1B2X,U,7)="S":"Seriously Ill",1:"")
+4 IF A1B2RA
SET A1B2RA=$PIECE(^DIC(25002.1,A1B2RA,0),U)
+5 IF A1B2DB
SET (X2,Y)=A1B2DB
DO DD^%DT
SET A1B2DB=Y
SET X1=DT
DO ^%DTC
SET A1B2AG=X\365.25
+6 IF A1B2BS
SET A1B2BS=$PIECE(^DIC(23,A1B2BS,0),U)
+7 FOR A1B2LP=0:0
SET A1B2LP=$ORDER(^A1B2(11500.2,"C",A1B2Y,A1B2LP))
if 'A1B2LP
QUIT
SET Y1=^A1B2(11500.2,A1B2LP,0)
IF $PIECE(Y1,U,15)
DO AD
+8 FOR A1B2LP=0:0
SET A1B2LP=$ORDER(^A1B2(11500.4,"C",A1B2Y,A1B2LP))
if 'A1B2LP
QUIT
SET Y1=^A1B2(11500.4,A1B2LP,0)
IF $PIECE(Y1,U,15)
DO RD
+9 QUIT
+10 ;
AD SET A1B2AS=$PIECE(Y1,U,3)
+1 ;FAC^DT AD^AD SP^DC DT^DC SP^TRAN TO^TRAN TY
+2 SET X=U_+Y1_U_$SELECT(A1B2AS:$PIECE(^DIC(42.4,A1B2AS,0),U),1:"")_U_$PIECE(Y1,U,6)_U_$SELECT($PIECE(Y1,U,5):$PIECE(^DG(405.2,$PIECE(Y1,U,5),0),U),1:"")_U_$PIECE(Y1,U,10)_U_$PIECE(Y1,U,11)
+3 XECUTE ^DD("FUNC",14,1)
SET $PIECE(X,U)=$PIECE(Y1,U,8)
SET A1B2AD(9999999-+Y1)=X
+4 QUIT
+5 ;
RD SET A1B2DP=$PIECE(Y1,U,5)
+1 SET X=U_+Y1_U_$SELECT(A1B2DP:$PIECE(^DIC(37,A1B2DP,0),U),1:"")
+2 XECUTE ^DD("FUNC",14,1)
SET $PIECE(X,U)=$PIECE(Y1,U,8)
SET A1B2RD(9999999-+Y1)=X
+3 QUIT
+4 ;
C ;Entry point for display.
+1 DO PG
DO HD1
+2 WRITE !!,"Patient: ",A1B2NA
IF A1B2CD'=""
IF $SELECT('$DATA(A1B2NTY):1,1:$PIECE(A1B2NTY,U,3))
WRITE ?45,"*** ",A1B2CD," ***"
+3 WRITE !,?4,"SSN: ",A1B2SS,?41,"Service Branch: ",$EXTRACT(A1B2BS,1,23)
+4 WRITE !,?4,"DOB: ",A1B2DB,?51,"Rank: ",A1B2RA
+5 WRITE !,?4,"Age: ",$SELECT($DATA(A1B2AG):A1B2AG,1:"")
+6 IF $DATA(A1B2NTY)
IF $DATA(A1B2X1)
DO ADD
+7 ;Came from A1B2ZUTL to display
+8 IF $DATA(A1B2ZU)
DO EX
QUIT
+9 SET A1B2L="- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - "
+10 SET A1B2E=1
+11 IF $DATA(A1B2AD)
WRITE !,A1B2L
FOR A1B2LP=0:0
SET A1B2LP=$ORDER(A1B2AD(A1B2LP))
if 'A1B2LP
QUIT
if $Y>(IOSL-5)
DO ST
if 'A1B2E
QUIT
DO WA
+12 IF $DATA(A1B2RD)
WRITE !!,A1B2L
FOR A1B2LP=0:0
SET A1B2LP=$ORDER(A1B2RD(A1B2LP))
if 'A1B2LP
QUIT
if $Y>(IOSL-5)
DO ST
if 'A1B2E
QUIT
DO WR
+13 WRITE !!!
+14 QUIT
+15 ;
WA WRITE !!,"Admitted to ",$SELECT($LENGTH($PIECE(A1B2AD(A1B2LP),U))>2:$EXTRACT($PIECE(A1B2AD(A1B2LP),U),1,26),1:"UNKNOWN")," on "
+1 SET Y=$PIECE(A1B2AD(A1B2LP),U,2)
DO DT^DIO2
WRITE " to ",$PIECE(A1B2AD(A1B2LP),U,3)
+2 IF $LENGTH($PIECE(A1B2AD(A1B2LP),U,4))>2
WRITE !," Discharged from ",$SELECT($LENGTH($PIECE(A1B2AD(A1B2LP),U))>2:$EXTRACT($PIECE(A1B2AD(A1B2LP),U),1,26),1:"UNKNOWN")," on "
+3 IF $LENGTH($PIECE(A1B2AD(A1B2LP),U,4))>2
SET Y=$PIECE(A1B2AD(A1B2LP),U,4)
DO DT^DIO2
WRITE " for ",$PIECE(A1B2AD(A1B2LP),U,5)
+4 IF $LENGTH($PIECE(A1B2AD(A1B2LP),U,6))>2
WRITE !," Transferred to ",$PIECE(A1B2AD(A1B2LP),U,6),$SELECT($PIECE(A1B2AD(A1B2LP),U,7)=0:" (VAMC)",1:" (UNKNOWN)")
+5 QUIT
+6 ;
WR WRITE !!,"Registered at ",$SELECT($LENGTH($PIECE(A1B2RD(A1B2LP),U))>2:$EXTRACT($PIECE(A1B2RD(A1B2LP),U),1,26),1:"UNKNOWN")," on "
+1 SET Y=$PIECE(A1B2RD(A1B2LP),U,2)
DO DT^DIO2
WRITE " for ",$PIECE(A1B2RD(A1B2LP),U,3)
+2 QUIT
+3 ;
HD1 ;Header for inquiry report.
+1 WRITE !,?25,"*** ODS Patient Inquiry ***"
+2 ;;;W !,"------------------------------------------------------------------------------"
+3 QUIT
+4 ;
EX ;Kill point.
+1 KILL DIC,A1B2X,A1B2SS,A1B2NA,A1B2DB,A1B2BS,A1B2AD,A1B2RD,A1B2DP,A1B2AS,Y,A1B2LP,A1B2Y,A1B2E,A1B2RA,DIR,Y1,A1B2CD,A1B2Y3,Y2,Y3,A1B2A1,A1B2A2,A1B2A3,A1B2A4,A1B2A5,A1B2A6,A1B2X1,X,A1B2L,A1B2AG
+2 QUIT
+3 ;
A ;Entry point for inquiry lookup.
+1 SET DIC="^A1B2(11500.1,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select Patient: "
+2 SET DIC("S")="I $P(^(0),U,8)=1 N X S X=$S($D(A1B2NTY):$P(A1B2NTY,U,2),1:"""") I $S(X=""""!(X=""A""):1,X=""V"":$D(^A1B2(11500.1,+Y,""NET"",""B"",+A1B2FN))>9,X=""R"":$D(^A1B2(11500.1,+Y,""NET"",""AR"",+A1B2VRG))>9,1:0)"
+3 DO ^DIC
KILL DIC
IF 'Y!(Y<0)
QUIT
+4 SET A1B2Y=+Y
+5 DO B
DO C
DO EX
GOTO A
