source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOLG.m@ 1700

Last change on this file since 1700 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.2 KB
Line 
1RMPOLG ;HIN-CIOFO/RVD - HOME OXYGEN LETTERS (MANAGE LETTER) ;7/24/98
2 ;;3.0;PROSTHETICS;**29,46**;Feb 09, 1996
3EN ; -- main entry point for manage letter list.
4 ; Input:
5 ; RMPOLCD - Selected Home Oxygen Letter code
6 ; Called by:
7 ; RMPOLZ - H.O. Letter Control module
8 D EN^VALM("RMPO MANAGE LETTER")
9 Q
10 ;
11HDR ; -- header code
12 S VALMHDR(1)=$$CNTR^RMPOLY(" ",$$EXTERNAL^DILFD(669.965,1,"",RMPOLCD),80)
13 S VALMHDR(2)=$$CNTR^RMPOLY(" ","HOME OXYGEN PATIENT LETTER LIST",80)
14 Q
15 ;
16INIT ; -- init variables and list array
17 N RMPODFN,REC,RMPOITEM,Y,X,SP
18 ;
19 ; for each entry in list for the selected letter type display details
20 S RMPONAM="",VALMCNT=0,$P(SP," ",80)=" "
21 F S RMPONAM=$O(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)) Q:RMPONAM="" D
22 . S RMPODFN=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
23 . S REC=^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN),VALMCNT=VALMCNT+1
24 . S Y=$P(REC,U,3) D DD^%DT S RMPORX=Y,Y=$P(REC,U,4)
25 . I Y'="" D DD^%DT
26 . I Y="" S Y="No Rx!"
27 . S RMPOEXP=Y,RMPOITEM=$P(REC,U,5)
28 . S:RMPOITEM="" RMPOITEM="No Primary!"
29 . ;
30 . S X=$$SETFLD^VALM1($E(VALMCNT_SP,1,$P(VALMDDF("LINE #"),U,3)),"","LINE #")
31 . S X=$$SETFLD^VALM1($P($P(REC,U),","),X,"PATIENT")
32 . S X=$$SETFLD^VALM1($P(REC,U,2),X,"SSN")
33 . S X=$$SETFLD^VALM1(RMPOITEM,X,"PRIMARY ITEM")
34 . S X=$$SETFLD^VALM1(RMPORX,X,"ACTIVATION DATE")
35 . S X=$$SETFLD^VALM1(RMPOEXP,X,"Rx EXPIRY DATE")
36 . D SET^VALM10(VALMCNT,X,RMPODFN)
37 Q
38 ;
39HELP ; -- help code
40 S X="?" D DISP^XQORM1 W !!
41 Q
42 ;
43EXIT ; -- exit code
44 D CLEAN^VALM10
45 Q
46 ;
47EN02 ; Delete list entry and code deleted in #665
48 N SEL,LINE
49 ; Select lines to delete
50 S SEL=$$SELN^RMPOLZA("L","Enter lines to delete",VALMCNT)
51 I SEL="^" S ^TMP($J,RMPOXITE,"EXIT")=1 Q ; quit to menu
52 Q:'SEL
53 N CNT
54 ; for each patient selected remove 'Letter to be sent' from
55 ; Prosthetics Patient File (665)
56 F CNT=1:1 S LINE=$P(SEL,",",CNT) Q:LINE="" D
57 . S RMPODFN=$O(@VALMAR@("IDX",LINE,""))
58 . S RMPONAM=$P(^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN),U,1)
59 . S RMPONAM=$E(RMPONAM,1,15)
60 . D UPDLTR^RMPOLZA(RMPODFN,"@")
61 . ; purge work file holding data
62 . K ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN)
63 . Q:'$D(RMPOLCD)
64 . I RMPOLCD="A" D
65 . . S $P(^RMPR(665,RMPODFN,"RMPOA"),U,09)=DT,$P(^RMPR(665,RMPODFN,"RMPOA"),U,10)="D"
66 . . S RMDBAT="RMPOXBAT1"
67 . I RMPOLCD="B" D
68 . . S $P(^RMPR(665,RMPODFN,"RMPOA"),U,11)=DT,$P(^RMPR(665,RMPODFN,"RMPOA"),U,12)="D"
69 . . S RMDBAT="RMPOXBAT2"
70 . I RMPOLCD="C" D
71 . . S $P(^RMPR(665,RMPODFN,"RMPOA"),U,13)=DT,$P(^RMPR(665,RMPODFN,"RMPOA"),U,14)="D"
72 . . S RMDBAT="RMPOXBAT3"
73 . S DA=$O(^RMPR(669.9,RMPOXITE,RMDBAT,"B",RMPODFN,0))
74 . S DIK="^RMPR(669.9,"_RMPOXITE_",",DA(1)=RMPOXITE
75 . S DIK=DIK_""""_RMDBAT_""""_"," D ^DIK
76 K DIK,DA
77 ;
78 G AMEND
79 ;
80ADD ; Add patient to the list entry.
81 D FULL^VALM1 W @IOF
82 K DIC,RMPODFN
83 S DIC("S")="I '$D(^TMP($J,RMPOXITE,""RMPODEMO"",+Y)),$D(^RMPR(665,+Y,""RMPOA"")),$P(^(""RMPOA""),U,3)="""",$P(^(0),U,2)=RMPOSITE"
84DIC S DIC="^RMPR(665,",DIC(0)="EAMQN" D ^DIC I Y<0 G AMEND
85 S RMPORX=$P($G(^RMPR(665,+Y,"RMPOB",0)),U,3) G:'$G(RMPORX) DIC
86 I $G(RMPORX),'$D(^RMPR(665,+Y,"RMPOB",RMPORX,0)) W !,"Patient has no current prescription!!" G DIC
87 S RMDEXP=$P(^RMPR(665,+Y,"RMPOB",RMPORX,0),U,3)
88 I RMPORX,RMDEXP,RMDEXP<DT W !,"Rx prescription has expired - Unable to ADD patient to the list !!",! G DIC
89 S RMPODFN=+Y,ADT=$P($G(^RMPR(665,+Y,"RMPOA")),U,2)
90 ;
91GETPAT ;get patient information(demographics)
92 D EXTRCT^RMPOLZA
93 S RMPONAM=$P(^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN),U,1)
94 ;S RMI="",RMPOLTR=0 F S RMI=$O(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMI)) Q:RMI="" S RMPOLTR=$P(^(RMI),U,1)
95 S RMCOD=$S(RMPOLCD="A":"RMPOXBAT1",RMPOLCD="B":"RMPOXBAT2",RMPOLCD="C":"RMPOXBAT3",1:"")
96 ;add the code to delete the entry in 665 for P and D entries and the dates.
97 Q:$D(^RMPR(669.9,RMPOXITE,RMCOD,"B",RMPODFN))
98 K DD,DO S DA(1)=RMPOXITE,DIC="^RMPR(669.9,"_RMPOXITE_","_""""_RMCOD_""""_","
99 S DIC(0)="L",X=RMPODFN,DLAYGO=669.9 D FILE^DICN
100 I '$D(DA) W !,"Patient was not added!!!" Q
101 S RMPOLTR=$G(LTRX("C",RMPOLCD))
102 S ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_DA
103 K DIC,DA,X
104 ;
105AMEND ; delete listman data and rebuild list from amended work file
106 D CLEAN^VALM10,INIT
107 Q:'$D(@VALMAR) ; Quit if there are no entries in list
108 S VALMBCK="R"
109 Q
Note: See TracBrowser for help on using the repository browser.