PRPFCD1 ;ALTOONA/CTB EXPANDED HEADER FOR PATIENT FUNDS CARD ;11/22/96 4:34 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
LHDR ;PRINTS THE EXPANDED HEADER FOR THE PATIENT CARD
F I=0,.31 S DFN(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
D ADD
S PDFN(0)=^PRPF(470,DFN,0),PDFN(1)=$S($D(^(1)):^(1),1:""),PDFN(2)=$S($D(^(2)):^(2),1:"")
D DGINPW^PRPFU1 W:$Y>1 @IOF
I $D(PRPF("ARCHIVE")) D
. S X="",$P(X," ",20)=""
. W "~~PRPF~~",!,$P(DFN(0),U)_"^"_$P(DFN(.31),U,3)_"^"_$P(DFN(0),"^",9),!
. S:$D(PGCOUNT)["0" PGCOUNT=0
. S PGCOUNT=PGCOUNT+1
. QUIT
W "BENEFICIARY: ",?32,"CLAIM #:",?48,"I.D. #",?64,"WARD",?75,"INDIGENT",?88,"DATE OF BIRTH",?105,"DATE OF ADMISSION"
W !,$P(DFN(0),U),?32,"C-",$P(DFN(.31),U,3),?48,$P(DFN(0),U,9),?64,$P(DFN(.1),U)
S X=$P(PDFN(0),U,5) I X]"" S DD=470,F=4 D ^PRPFU1 W ?78,Y
S Y=$P(DFN(0),U,3) D D^PRPFU1 W ?89,Y,?105,DOA
W !!,"TYPE OF ACCOUNT",?25,"DATE OF RESTRICTION",?50,"COMPETENCY",?84,"APPORTIONEE",?100,"GUARDIAN",?116,"INST'L AWARD"
S X=$P(PDFN(0),U,3),F=2,DD=470 D ^PRPFU1 W !,Y
S Y=$P(PDFN(0),U,12) D D^PRPFU1 W ?25,Y
S X=$P(PDFN(0),U,4),F=3,DD=470 D ^PRPFU1
W ?50,Y,?86,"$",$J($P(PDFN(0),U,6),0,2),?100,"$",$J($P(PDFN(0),U,7),0,2),?118,"$",$J($P(PDFN(0),U,8),0,2)
W !!,"PATIENT ADDRESS",?32,"NEAREST RELATIVE",?64,"VA GUARDIAN",?96,"CIVIL GUARDIAN"
F I=1:1:9 I $P(DFN(.11),U,I)]""!($P(DFN(.21),U,I)]"")!($P(DFN(.29),U,I)]"")!($P(DFN(.291),U,I)]"") W !,$E($P(DFN(.11),U,I),1,30),?32,$E($P(DFN(.21),U,I),1,30),?64,$E($P(DFN(.29),U,I),1,30),?96,$E($P(DFN(.291),U,I),1,30)
W !,LINE
G LHDR1^PRPFCD
Q
ADD ;COMPRESS ADDRESS INFO
;COMPRESS VA GUARDIAN ADDRESS
K TMP S:$D(^DPT(DFN,.29)) TMP=^(.29) S DFN(.29)="" G:'$D(TMP) ADD1 I $P(TMP,"^",4)="" K TMP G ADD1
S DFN(.29)=$P(TMP,"^",4),J=2 F I=6,7 I $P(TMP,"^",I)]"" S $P(DFN(.29),"^",J)=$P(TMP,"^",I) S J=J+1
S:$P(TMP,"^",8)]"" $P(DFN(.29),"^",J)=$P(TMP,"^",8)_","
I +$P(TMP,"^",9)>0 S $P(DFN(.29),"^",J)=$P(DFN(.29),"^",J)_$P(^DIC(5,$P(TMP,"^",9),0),"^",2)_" "_$P(TMP,"^",10) S J=J+1
S:$P(TMP,"^",11)]"" $P(DFN(.29),"^",J)=$P(TMP,"^",11)
ADD1 ;COMPRESS RELATIVE ADDRESS
K TMP S:$D(^DPT(DFN,.21)) TMP=^(.21) S DFN(.21)="" G:'$D(TMP) ADD2 I $P(TMP,"^",1)="" K TMP G ADD2
S DFN(.21)=$P(TMP,"^"),J=2 F I=3:1:5 I $P(TMP,"^",I)]"" S $P(DFN(.21),"^",J)=$P(TMP,"^",I),J=J+1
S:$P(TMP,"^",6)]"" $P(DFN(.21),"^",J)=$P(TMP,"^",6)_","
I +$P(TMP,"^",7)>0 S $P(DFN(.21),"^",J)=$P(DFN(.21),"^",J)_$P(^DIC(5,$P(TMP,"^",7),0),"^",2)_" "_$P(TMP,"^",8),J=J+1
S:$P(TMP,"^",9)]"" $P(DFN(.21),"^",J)=$P(TMP,"^",9)
K TMP
ADD2 ;COMPRESS PATIENT ADDRESS
K TMP S:$D(^DPT(DFN,.11)) TMP=^(.11) S DFN(.11)="" G:'$D(TMP) ADD3 I $P(TMP,"^",1)="" K TMP G ADD3
S J=1 F I=1:1:3 I $P(TMP,"^",I)]"" S $P(DFN(.11),"^",J)=$P(TMP,"^",I),J=J+1
S:$P(TMP,"^",4)]"" $P(DFN(.11),"^",J)=$P(TMP,"^",4)_","
I +$P(TMP,"^",5)>0 S $P(DFN(.11),"^",J)=$P(DFN(.11),"^",J)_$P(^DIC(5,$P(TMP,"^",5),0),"^",2)_" "_$P(TMP,"^",6),J=J+1
I $D(^DPT(DFN,.13)),$P(^(.13),U,1)]"" S $P(DFN(.11),U,J)=$P(^(.13),U)
ADD3 ;COMPRESS CIVIL GUARDIAN ADDRESS
K TMP S:$D(^DPT(DFN,.291)) TMP=^(.291) S DFN(.291)="" Q:'$D(TMP) I $P(TMP,"^",4)="" K TMP,J,I Q
S DFN(.291)=$P(TMP,"^",4),J=2 F I=6,7 I $P(TMP,"^",I)]"" S $P(DFN(.291),"^",J)=$P(TMP,"^",I) S J=J+1
S:$P(TMP,"^",8)]"" $P(DFN(.291),"^",J)=$P(TMP,"^",8)_","
I +$P(TMP,"^",9)>0 S $P(DFN(.291),"^",J)=$P(DFN(.291),"^",J)_$P(^DIC(5,$P(TMP,"^",9),0),"^",2)_" "_$P(TMP,"^",10) S J=J+1
S:$P(TMP,"^",11)]"" $P(DFN(.291),"^",J)=$P(TMP,"^",11)
K TMP,J,I Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFCD1 3495 printed Dec 13, 2024@02:01:29 Page 2
PRPFCD1 ;ALTOONA/CTB EXPANDED HEADER FOR PATIENT FUNDS CARD ;11/22/96 4:34 PM
V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
LHDR ;PRINTS THE EXPANDED HEADER FOR THE PATIENT CARD
+1 FOR I=0,.31
SET DFN(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+2 DO ADD
+3 SET PDFN(0)=^PRPF(470,DFN,0)
SET PDFN(1)=$SELECT($DATA(^(1)):^(1),1:"")
SET PDFN(2)=$SELECT($DATA(^(2)):^(2),1:"")
+4 DO DGINPW^PRPFU1
if $Y>1
WRITE @IOF
+5 IF $DATA(PRPF("ARCHIVE"))
Begin DoDot:1
+6 SET X=""
SET $PIECE(X," ",20)=""
+7 WRITE "~~PRPF~~",!,$PIECE(DFN(0),U)_"^"_$PIECE(DFN(.31),U,3)_"^"_$PIECE(DFN(0),"^",9),!
+8 if $DATA(PGCOUNT)["0"
SET PGCOUNT=0
+9 SET PGCOUNT=PGCOUNT+1
+10 QUIT
End DoDot:1
+11 WRITE "BENEFICIARY: ",?32,"CLAIM #:",?48,"I.D. #",?64,"WARD",?75,"INDIGENT",?88,"DATE OF BIRTH",?105,"DATE OF ADMISSION"
+12 WRITE !,$PIECE(DFN(0),U),?32,"C-",$PIECE(DFN(.31),U,3),?48,$PIECE(DFN(0),U,9),?64,$PIECE(DFN(.1),U)
+13 SET X=$PIECE(PDFN(0),U,5)
IF X]""
SET DD=470
SET F=4
DO ^PRPFU1
WRITE ?78,Y
+14 SET Y=$PIECE(DFN(0),U,3)
DO D^PRPFU1
WRITE ?89,Y,?105,DOA
+15 WRITE !!,"TYPE OF ACCOUNT",?25,"DATE OF RESTRICTION",?50,"COMPETENCY",?84,"APPORTIONEE",?100,"GUARDIAN",?116,"INST'L AWARD"
+16 SET X=$PIECE(PDFN(0),U,3)
SET F=2
SET DD=470
DO ^PRPFU1
WRITE !,Y
+17 SET Y=$PIECE(PDFN(0),U,12)
DO D^PRPFU1
WRITE ?25,Y
+18 SET X=$PIECE(PDFN(0),U,4)
SET F=3
SET DD=470
DO ^PRPFU1
+19 WRITE ?50,Y,?86,"$",$JUSTIFY($PIECE(PDFN(0),U,6),0,2),?100,"$",$JUSTIFY($PIECE(PDFN(0),U,7),0,2),?118,"$",$JUSTIFY($PIECE(PDFN(0),U,8),0,2)
+20 WRITE !!,"PATIENT ADDRESS",?32,"NEAREST RELATIVE",?64,"VA GUARDIAN",?96,"CIVIL GUARDIAN"
+21 FOR I=1:1:9
IF $PIECE(DFN(.11),U,I)]""!($PIECE(DFN(.21),U,I)]"")!($PIECE(DFN(.29),U,I)]"")!($PIECE(DFN(.291),U,I)]"")
WRITE !,$EXTRACT($PIECE(DFN(.11),U,I),1,30),?32,$EXTRACT($PIECE(DFN(.21),U,I),1,30),?64,$EXTRACT($PIECE(DFN(.29),U,I),1,30),?96,$EXTRACT($PIECE(DFN(.291),U,I),1,30)
+22 WRITE !,LINE
+23 GOTO LHDR1^PRPFCD
+24 QUIT
ADD ;COMPRESS ADDRESS INFO
+1 ;COMPRESS VA GUARDIAN ADDRESS
+2 KILL TMP
if $DATA(^DPT(DFN,.29))
SET TMP=^(.29)
SET DFN(.29)=""
if '$DATA(TMP)
GOTO ADD1
IF $PIECE(TMP,"^",4)=""
KILL TMP
GOTO ADD1
+3 SET DFN(.29)=$PIECE(TMP,"^",4)
SET J=2
FOR I=6,7
IF $PIECE(TMP,"^",I)]""
SET $PIECE(DFN(.29),"^",J)=$PIECE(TMP,"^",I)
SET J=J+1
+4 if $PIECE(TMP,"^",8)]""
SET $PIECE(DFN(.29),"^",J)=$PIECE(TMP,"^",8)_","
+5 IF +$PIECE(TMP,"^",9)>0
SET $PIECE(DFN(.29),"^",J)=$PIECE(DFN(.29),"^",J)_$PIECE(^DIC(5,$PIECE(TMP,"^",9),0),"^",2)_" "_$PIECE(TMP,"^",10)
SET J=J+1
+6 if $PIECE(TMP,"^",11)]""
SET $PIECE(DFN(.29),"^",J)=$PIECE(TMP,"^",11)
ADD1 ;COMPRESS RELATIVE ADDRESS
+1 KILL TMP
if $DATA(^DPT(DFN,.21))
SET TMP=^(.21)
SET DFN(.21)=""
if '$DATA(TMP)
GOTO ADD2
IF $PIECE(TMP,"^",1)=""
KILL TMP
GOTO ADD2
+2 SET DFN(.21)=$PIECE(TMP,"^")
SET J=2
FOR I=3:1:5
IF $PIECE(TMP,"^",I)]""
SET $PIECE(DFN(.21),"^",J)=$PIECE(TMP,"^",I)
SET J=J+1
+3 if $PIECE(TMP,"^",6)]""
SET $PIECE(DFN(.21),"^",J)=$PIECE(TMP,"^",6)_","
+4 IF +$PIECE(TMP,"^",7)>0
SET $PIECE(DFN(.21),"^",J)=$PIECE(DFN(.21),"^",J)_$PIECE(^DIC(5,$PIECE(TMP,"^",7),0),"^",2)_" "_$PIECE(TMP,"^",8)
SET J=J+1
+5 if $PIECE(TMP,"^",9)]""
SET $PIECE(DFN(.21),"^",J)=$PIECE(TMP,"^",9)
+6 KILL TMP
ADD2 ;COMPRESS PATIENT ADDRESS
+1 KILL TMP
if $DATA(^DPT(DFN,.11))
SET TMP=^(.11)
SET DFN(.11)=""
if '$DATA(TMP)
GOTO ADD3
IF $PIECE(TMP,"^",1)=""
KILL TMP
GOTO ADD3
+2 SET J=1
FOR I=1:1:3
IF $PIECE(TMP,"^",I)]""
SET $PIECE(DFN(.11),"^",J)=$PIECE(TMP,"^",I)
SET J=J+1
+3 if $PIECE(TMP,"^",4)]""
SET $PIECE(DFN(.11),"^",J)=$PIECE(TMP,"^",4)_","
+4 IF +$PIECE(TMP,"^",5)>0
SET $PIECE(DFN(.11),"^",J)=$PIECE(DFN(.11),"^",J)_$PIECE(^DIC(5,$PIECE(TMP,"^",5),0),"^",2)_" "_$PIECE(TMP,"^",6)
SET J=J+1
+5 IF $DATA(^DPT(DFN,.13))
IF $PIECE(^(.13),U,1)]""
SET $PIECE(DFN(.11),U,J)=$PIECE(^(.13),U)
ADD3 ;COMPRESS CIVIL GUARDIAN ADDRESS
+1 KILL TMP
if $DATA(^DPT(DFN,.291))
SET TMP=^(.291)
SET DFN(.291)=""
if '$DATA(TMP)
QUIT
IF $PIECE(TMP,"^",4)=""
KILL TMP,J,I
QUIT
+2 SET DFN(.291)=$PIECE(TMP,"^",4)
SET J=2
FOR I=6,7
IF $PIECE(TMP,"^",I)]""
SET $PIECE(DFN(.291),"^",J)=$PIECE(TMP,"^",I)
SET J=J+1
+3 if $PIECE(TMP,"^",8)]""
SET $PIECE(DFN(.291),"^",J)=$PIECE(TMP,"^",8)_","
+4 IF +$PIECE(TMP,"^",9)>0
SET $PIECE(DFN(.291),"^",J)=$PIECE(DFN(.291),"^",J)_$PIECE(^DIC(5,$PIECE(TMP,"^",9),0),"^",2)_" "_$PIECE(TMP,"^",10)
SET J=J+1
+5 if $PIECE(TMP,"^",11)]""
SET $PIECE(DFN(.291),"^",J)=$PIECE(TMP,"^",11)
+6 KILL TMP,J,I
QUIT
