- 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 Jan 18, 2025@03:02:41 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