- RMPOLF0 ;HIN CIOFO/RVD-DRIVER FOR HO LETTERS ;06/22/99
- ;;3.0;PROSTHETICS;**29,55,115,159**;Feb 09, 1996;Build 2
- ;
- ; ODJ - patch 55 - 1/29/01 - replace 121 hard code mail symbol with
- ; call to site param. extrinsic
- ; see nois AUG-1097-32118
- ;
- D HOME^%ZIS S RMPRIN=0
- K VADM,^TMP("RL",$J)
- S Y=DT D DD^%DT S NAME=Y D TRANS^RMPRUTL1 S (RMPODT,RMPODATE)=RMPRNAME
- D PIKSOM Q:$$QUIT I Y="" S VALMBCK="R" Q
- M ^TMP("RL",$J)=^TMP($J)
- S LFNS=Y I 'JOB D FULL^VALM1
- ;
- QUED ;
- F ZI=1:1:$L(LFNS,",")-1 D
- . S LFN=$P(LFNS,",",ZI) Q:LFN'>0
- . S RMPONAM="",CNT=0 F S RMPONAM=$O(^TMP("RL",$J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)) Q:RMPONAM="" D
- .. S RMPOLTR=$P(^TMP("RL",$J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
- .. S RMPODFN=$P(^TMP("RL",$J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
- .. S RMDA=$P(^TMP("RL",$J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,3)
- .. S CNT=CNT+1
- .. S:CNT=LFN ^TMP("RL",$J,RMPOXITE,"LTR",RMPONAM)=RMPODFN_"^"_RMPOLTR_"^"_RMDA
- S (RMBLNK,RMPONAM)="",RMQUIT=0
- F S RMPONAM=$O(^TMP("RL",$J,RMPOXITE,"LTR",RMPONAM)) Q:RMPONAM=""!$G(RMQUIT) D CUM
- ;end
- EXIT ;
- K LFNS,LFN,ZI,RTN,DIR,RMLET,^TMP($J)
- K %X,RMPRFFL,RMPRHED,RMPRPRIN,%Y,RMPRDEL,RMPRRVA,DIC,RMPRFA,KILL,DIE,DA
- K DR,DIK,RMPR1,RMPR2,RMPRDATE,RMPRIN,RMPRL,RMPRNAME,RMPRU,RMPRDELE,FR
- K RMPREND,VADM,VAPA,VA,NAME,RMPRGO,NAME1,RMPONAM
- K RMPRDEN,RMPRFLAG,RMPRNAM1,RMPRNAM2,RMPRFF,J,RP,RO,RZ D KVAR^VADPT
- M ^TMP($J)=^TMP("RL",$J) K ^TMP("RL",$J)
- D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q:$D(ZTQUEUED)
- D HOME^%ZIS D CLEAN^VALM10,INIT^RMPOLT S VALMBCK="R"
- Q
- ;
- CUM ;
- K RMPRNT S RDATA=^TMP("RL",$J,RMPOXITE,"LTR",RMPONAM)
- S DFN=$P(RDATA,U,1),RMPOLTR=$P(RDATA,U,2),RMDA=$P(RDATA,U,3)
- S RMREC=^TMP("RL",$J,RMPOXITE,"RMPODEMO",DFN)
- S RMPORX=$P(RMREC,U,6) S:RMPORX="" RMPORX="Not on file"
- S RMPORXDT=$P(RMREC,U,4)
- I RMPORXDT="" S RMPORXDT="n/a"
- E S Y=RMPORXDT X ^DD("DD") S RMPORXDT=Y
- S RMPRFA=RMPOLTR
- D DEM^VADPT,ADD^VADPT
- F RI=1:1:21 S ^TMP($J,"DW",RI,0)=" "
- S RMPRHED=$G(^TMP("RL",$J,RMPOXITE,"HEADER",RMPOLTR))
- W @IOF I 'RMPRHED G HEADER
- S ^TMP($J,"DW",1,0)="|SETTAB(""C"")|"
- S ^TMP($J,"DW",2,0)="|TAB|Department of Veterans Affairs"
- S NAME=$P(^RMPR(669.9,RMPOXITE,2),U,4) I NAME]"" S NAME=$S($D(^DIC(5,NAME)):$P(^DIC(5,NAME,0),U),1:"STATE") S RMFXN=$$PARS^RMPRUTL1(NAME)
- S ^TMP($J,"DW",3,0)="|TAB|"_$P(^RMPR(669.9,RMPOXITE,0),U)
- S ^TMP($J,"DW",4,0)="|TAB|"_$P(^RMPR(669.9,RMPOXITE,2),U,2)
- S ^TMP($J,"DW",5,0)="|TAB|"_$P(^RMPR(669.9,RMPOXITE,2),U,3)_", "_RMFXN_" "_$P(^RMPR(669.9,RMPOXITE,2),U,5) K RMFXN
- S ^TMP($J,"DW",9,0)="|SETTAB(5,50)||TAB|"_RMPODT
- S STATNID=$P(^RMPR(669.9,RMPOXITE,0),U,2) I $D(^DIC(4,STATNID,99)) S STATNID=$P(^DIC(4,STATNID,99),U)
- S ^TMP($J,"DW",11,0)="|TAB|"_$P(VADM(1),",",2)_" "_$P(VADM(1),",",1)_"|TAB|In Reply Refer To: "_STATNID_"/"_$$ROU^RMPRUTIL(RMPOXITE)
- K STATNID
- S ^TMP($J,"DW",12,0)="|TAB|"_VAPA(1)
- I VAPA(2)]"" S ^TMP($J,"DW",13,0)="|TAB|"_VAPA(2)_"|TAB|"_VADM(1),^TMP($J,"DW",14,0)="|TAB|"_VAPA(4)_","_" "_$P(VAPA(5),U,2)_" "_VAPA(6)
- E S ^TMP($J,"DW",13,0)="|TAB|"_VAPA(4)_","_" "_$P(VAPA(5),U,2)_" "_VAPA(6)_"|TAB|"_VADM(1)
- ;
- S ^TMP($J,"DW",15,0)="|TAB|"_RMBLNK_"|TAB|"_DFN
- S ^TMP($J,"DW",16,0)="|TAB|"_RMBLNK_"|TAB|Current Home Oxygen Rx#: "_RMPORX
- S ^TMP($J,"DW",17,0)="|TAB|"_RMBLNK_"|TAB|Rx Expiration Date: "_RMPORXDT
- ;
- S NAME=$P(VADM(1),",")
- I $P(NAME," ",2)?1A.A D
- .S NAME1=NAME,NAME=$P(NAME," ",1) D TRANS^RMPRUTL1 S RMPRNAM1=RMPRNAME,NAME=NAME1,NAME=$P(NAME," ",2) D TRANS^RMPRUTL1 S RMPRNAM2=RMPRNAME,RMPRNAME=RMPRNAM1_" "_RMPRNAM2
- E D TRANS^RMPRUTL1
- D NAME^RMPOLF1
- Q
- QUIT() S QUIT=$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q QUIT
- Q
- PIKSOM ; ALLOW SELECTION FROM DISPLAYED ENTRIES
- K DIR S DIR(0)="LO^"_VALMBG_":"_VALMLST D ^DIR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOLF0 3833 printed Feb 18, 2025@23:57:28 Page 2
- RMPOLF0 ;HIN CIOFO/RVD-DRIVER FOR HO LETTERS ;06/22/99
- +1 ;;3.0;PROSTHETICS;**29,55,115,159**;Feb 09, 1996;Build 2
- +2 ;
- +3 ; ODJ - patch 55 - 1/29/01 - replace 121 hard code mail symbol with
- +4 ; call to site param. extrinsic
- +5 ; see nois AUG-1097-32118
- +6 ;
- +7 DO HOME^%ZIS
- SET RMPRIN=0
- +8 KILL VADM,^TMP("RL",$JOB)
- +9 SET Y=DT
- DO DD^%DT
- SET NAME=Y
- DO TRANS^RMPRUTL1
- SET (RMPODT,RMPODATE)=RMPRNAME
- +10 DO PIKSOM
- if $$QUIT
- QUIT
- IF Y=""
- SET VALMBCK="R"
- QUIT
- +11 MERGE ^TMP("RL",$JOB)=^TMP($JOB)
- +12 SET LFNS=Y
- IF 'JOB
- DO FULL^VALM1
- +13 ;
- QUED ;
- +1 FOR ZI=1:1:$LENGTH(LFNS,",")-1
- Begin DoDot:1
- +2 SET LFN=$PIECE(LFNS,",",ZI)
- if LFN'>0
- QUIT
- +3 SET RMPONAM=""
- SET CNT=0
- FOR
- SET RMPONAM=$ORDER(^TMP("RL",$JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM))
- if RMPONAM=""
- QUIT
- Begin DoDot:2
- +4 SET RMPOLTR=$PIECE(^TMP("RL",$JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
- +5 SET RMPODFN=$PIECE(^TMP("RL",$JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
- +6 SET RMDA=$PIECE(^TMP("RL",$JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,3)
- +7 SET CNT=CNT+1
- +8 if CNT=LFN
- SET ^TMP("RL",$JOB,RMPOXITE,"LTR",RMPONAM)=RMPODFN_"^"_RMPOLTR_"^"_RMDA
- End DoDot:2
- End DoDot:1
- +9 SET (RMBLNK,RMPONAM)=""
- SET RMQUIT=0
- +10 FOR
- SET RMPONAM=$ORDER(^TMP("RL",$JOB,RMPOXITE,"LTR",RMPONAM))
- if RMPONAM=""!$GET(RMQUIT)
- QUIT
- DO CUM
- +11 ;end
- EXIT ;
- +1 KILL LFNS,LFN,ZI,RTN,DIR,RMLET,^TMP($JOB)
- +2 KILL %X,RMPRFFL,RMPRHED,RMPRPRIN,%Y,RMPRDEL,RMPRRVA,DIC,RMPRFA,KILL,DIE,DA
- +3 KILL DR,DIK,RMPR1,RMPR2,RMPRDATE,RMPRIN,RMPRL,RMPRNAME,RMPRU,RMPRDELE,FR
- +4 KILL RMPREND,VADM,VAPA,VA,NAME,RMPRGO,NAME1,RMPONAM
- +5 KILL RMPRDEN,RMPRFLAG,RMPRNAM1,RMPRNAM2,RMPRFF,J,RP,RO,RZ
- DO KVAR^VADPT
- +6 MERGE ^TMP($JOB)=^TMP("RL",$JOB)
- KILL ^TMP("RL",$JOB)
- +7 DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- if $DATA(ZTQUEUED)
- QUIT
- +8 DO HOME^%ZIS
- DO CLEAN^VALM10
- DO INIT^RMPOLT
- SET VALMBCK="R"
- +9 QUIT
- +10 ;
- CUM ;
- +1 KILL RMPRNT
- SET RDATA=^TMP("RL",$JOB,RMPOXITE,"LTR",RMPONAM)
- +2 SET DFN=$PIECE(RDATA,U,1)
- SET RMPOLTR=$PIECE(RDATA,U,2)
- SET RMDA=$PIECE(RDATA,U,3)
- +3 SET RMREC=^TMP("RL",$JOB,RMPOXITE,"RMPODEMO",DFN)
- +4 SET RMPORX=$PIECE(RMREC,U,6)
- if RMPORX=""
- SET RMPORX="Not on file"
- +5 SET RMPORXDT=$PIECE(RMREC,U,4)
- +6 IF RMPORXDT=""
- SET RMPORXDT="n/a"
- +7 IF '$TEST
- SET Y=RMPORXDT
- XECUTE ^DD("DD")
- SET RMPORXDT=Y
- +8 SET RMPRFA=RMPOLTR
- +9 DO DEM^VADPT
- DO ADD^VADPT
- +10 FOR RI=1:1:21
- SET ^TMP($JOB,"DW",RI,0)=" "
- +1 SET RMPRHED=$GET(^TMP("RL",$JOB,RMPOXITE,"HEADER",RMPOLTR))
- +2 WRITE @IOF
- IF 'RMPRHED
- GOTO HEADER
- +3 SET ^TMP($JOB,"DW",1,0)="|SETTAB(""C"")|"
- +4 SET ^TMP($JOB,"DW",2,0)="|TAB|Department of Veterans Affairs"
- +5 SET NAME=$PIECE(^RMPR(669.9,RMPOXITE,2),U,4)
- IF NAME]""
- SET NAME=$SELECT($DATA(^DIC(5,NAME)):$PIECE(^DIC(5,NAME,0),U),1:"STATE")
- SET RMFXN=$$PARS^RMPRUTL1(NAME)
- +6 SET ^TMP($JOB,"DW",3,0)="|TAB|"_$PIECE(^RMPR(669.9,RMPOXITE,0),U)
- +7 SET ^TMP($JOB,"DW",4,0)="|TAB|"_$PIECE(^RMPR(669.9,RMPOXITE,2),U,2)
- +8 SET ^TMP($JOB,"DW",5,0)="|TAB|"_$PIECE(^RMPR(669.9,RMPOXITE,2),U,3)_", "_RMFXN_" "_$PIECE(^RMPR(669.9,RMPOXITE,2),U,5)
- KILL RMFXN
- +1 SET ^TMP($JOB,"DW",9,0)="|SETTAB(5,50)||TAB|"_RMPODT
- +2 SET STATNID=$PIECE(^RMPR(669.9,RMPOXITE,0),U,2)
- IF $DATA(^DIC(4,STATNID,99))
- SET STATNID=$PIECE(^DIC(4,STATNID,99),U)
- +3 SET ^TMP($JOB,"DW",11,0)="|TAB|"_$PIECE(VADM(1),",",2)_" "_$PIECE(VADM(1),",",1)_"|TAB|In Reply Refer To: "_STATNID_"/"_$$ROU^RMPRUTIL(RMPOXITE)
- +4 KILL STATNID
- +5 SET ^TMP($JOB,"DW",12,0)="|TAB|"_VAPA(1)
- +6 IF VAPA(2)]""
- SET ^TMP($JOB,"DW",13,0)="|TAB|"_VAPA(2)_"|TAB|"_VADM(1)
- SET ^TMP($JOB,"DW",14,0)="|TAB|"_VAPA(4)_","_" "_$PIECE(VAPA(5),U,2)_" "_VAPA(6)
- +7 IF '$TEST
- SET ^TMP($JOB,"DW",13,0)="|TAB|"_VAPA(4)_","_" "_$PIECE(VAPA(5),U,2)_" "_VAPA(6)_"|TAB|"_VADM(1)
- +8 ;
- +9 SET ^TMP($JOB,"DW",15,0)="|TAB|"_RMBLNK_"|TAB|"_DFN
- +10 SET ^TMP($JOB,"DW",16,0)="|TAB|"_RMBLNK_"|TAB|Current Home Oxygen Rx#: "_RMPORX
- +11 SET ^TMP($JOB,"DW",17,0)="|TAB|"_RMBLNK_"|TAB|Rx Expiration Date: "_RMPORXDT
- +12 ;
- +13 SET NAME=$PIECE(VADM(1),",")
- +14 IF $PIECE(NAME," ",2)?1A.A
- Begin DoDot:1
- +15 SET NAME1=NAME
- SET NAME=$PIECE(NAME," ",1)
- DO TRANS^RMPRUTL1
- SET RMPRNAM1=RMPRNAME
- SET NAME=NAME1
- SET NAME=$PIECE(NAME," ",2)
- DO TRANS^RMPRUTL1
- SET RMPRNAM2=RMPRNAME
- SET RMPRNAME=RMPRNAM1_" "_RMPRNAM2
- End DoDot:1
- +16 IF '$TEST
- DO TRANS^RMPRUTL1
- +17 DO NAME^RMPOLF1
- +18 QUIT
- QUIT() SET QUIT=$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
- QUIT QUIT
- +1 QUIT
- PIKSOM ; ALLOW SELECTION FROM DISPLAYED ENTRIES
- +1 KILL DIR
- SET DIR(0)="LO^"_VALMBG_":"_VALMLST
- DO ^DIR
- +2 QUIT