RMPOLG ;HIN-CIOFO/RVD - HOME OXYGEN LETTERS (MANAGE LETTER) ;7/24/98
;;3.0;PROSTHETICS;**29,46**;Feb 09, 1996
EN ; -- main entry point for manage letter list.
; Input:
; RMPOLCD - Selected Home Oxygen Letter code
; Called by:
; RMPOLZ - H.O. Letter Control module
D EN^VALM("RMPO MANAGE LETTER")
Q
;
HDR ; -- header code
S VALMHDR(1)=$$CNTR^RMPOLY(" ",$$EXTERNAL^DILFD(669.965,1,"",RMPOLCD),80)
S VALMHDR(2)=$$CNTR^RMPOLY(" ","HOME OXYGEN PATIENT LETTER LIST",80)
Q
;
INIT ; -- init variables and list array
N RMPODFN,REC,RMPOITEM,Y,X,SP
;
; for each entry in list for the selected letter type display details
S RMPONAM="",VALMCNT=0,$P(SP," ",80)=" "
F S RMPONAM=$O(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)) Q:RMPONAM="" D
. S RMPODFN=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
. S REC=^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN),VALMCNT=VALMCNT+1
. S Y=$P(REC,U,3) D DD^%DT S RMPORX=Y,Y=$P(REC,U,4)
. I Y'="" D DD^%DT
. I Y="" S Y="No Rx!"
. S RMPOEXP=Y,RMPOITEM=$P(REC,U,5)
. S:RMPOITEM="" RMPOITEM="No Primary!"
. ;
. S X=$$SETFLD^VALM1($E(VALMCNT_SP,1,$P(VALMDDF("LINE #"),U,3)),"","LINE #")
. S X=$$SETFLD^VALM1($P($P(REC,U),","),X,"PATIENT")
. S X=$$SETFLD^VALM1($P(REC,U,2),X,"SSN")
. S X=$$SETFLD^VALM1(RMPOITEM,X,"PRIMARY ITEM")
. S X=$$SETFLD^VALM1(RMPORX,X,"ACTIVATION DATE")
. S X=$$SETFLD^VALM1(RMPOEXP,X,"Rx EXPIRY DATE")
. D SET^VALM10(VALMCNT,X,RMPODFN)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D CLEAN^VALM10
Q
;
EN02 ; Delete list entry and code deleted in #665
N SEL,LINE
; Select lines to delete
S SEL=$$SELN^RMPOLZA("L","Enter lines to delete",VALMCNT)
I SEL="^" S ^TMP($J,RMPOXITE,"EXIT")=1 Q ; quit to menu
Q:'SEL
N CNT
; for each patient selected remove 'Letter to be sent' from
; Prosthetics Patient File (665)
F CNT=1:1 S LINE=$P(SEL,",",CNT) Q:LINE="" D
. S RMPODFN=$O(@VALMAR@("IDX",LINE,""))
. S RMPONAM=$P(^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN),U,1)
. S RMPONAM=$E(RMPONAM,1,15)
. D UPDLTR^RMPOLZA(RMPODFN,"@")
. ; purge work file holding data
. K ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN)
. Q:'$D(RMPOLCD)
. I RMPOLCD="A" D
. . S $P(^RMPR(665,RMPODFN,"RMPOA"),U,09)=DT,$P(^RMPR(665,RMPODFN,"RMPOA"),U,10)="D"
. . S RMDBAT="RMPOXBAT1"
. I RMPOLCD="B" D
. . S $P(^RMPR(665,RMPODFN,"RMPOA"),U,11)=DT,$P(^RMPR(665,RMPODFN,"RMPOA"),U,12)="D"
. . S RMDBAT="RMPOXBAT2"
. I RMPOLCD="C" D
. . S $P(^RMPR(665,RMPODFN,"RMPOA"),U,13)=DT,$P(^RMPR(665,RMPODFN,"RMPOA"),U,14)="D"
. . S RMDBAT="RMPOXBAT3"
. S DA=$O(^RMPR(669.9,RMPOXITE,RMDBAT,"B",RMPODFN,0))
. S DIK="^RMPR(669.9,"_RMPOXITE_",",DA(1)=RMPOXITE
. S DIK=DIK_""""_RMDBAT_""""_"," D ^DIK
K DIK,DA
;
G AMEND
;
ADD ; Add patient to the list entry.
D FULL^VALM1 W @IOF
K DIC,RMPODFN
S DIC("S")="I '$D(^TMP($J,RMPOXITE,""RMPODEMO"",+Y)),$D(^RMPR(665,+Y,""RMPOA"")),$P(^(""RMPOA""),U,3)="""",$P(^(0),U,2)=RMPOSITE"
DIC S DIC="^RMPR(665,",DIC(0)="EAMQN" D ^DIC I Y<0 G AMEND
S RMPORX=$P($G(^RMPR(665,+Y,"RMPOB",0)),U,3) G:'$G(RMPORX) DIC
I $G(RMPORX),'$D(^RMPR(665,+Y,"RMPOB",RMPORX,0)) W !,"Patient has no current prescription!!" G DIC
S RMDEXP=$P(^RMPR(665,+Y,"RMPOB",RMPORX,0),U,3)
I RMPORX,RMDEXP,RMDEXP<DT W !,"Rx prescription has expired - Unable to ADD patient to the list !!",! G DIC
S RMPODFN=+Y,ADT=$P($G(^RMPR(665,+Y,"RMPOA")),U,2)
;
GETPAT ;get patient information(demographics)
D EXTRCT^RMPOLZA
S RMPONAM=$P(^TMP($J,RMPOXITE,"RMPODEMO",RMPODFN),U,1)
;S RMI="",RMPOLTR=0 F S RMI=$O(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMI)) Q:RMI="" S RMPOLTR=$P(^(RMI),U,1)
S RMCOD=$S(RMPOLCD="A":"RMPOXBAT1",RMPOLCD="B":"RMPOXBAT2",RMPOLCD="C":"RMPOXBAT3",1:"")
;add the code to delete the entry in 665 for P and D entries and the dates.
Q:$D(^RMPR(669.9,RMPOXITE,RMCOD,"B",RMPODFN))
K DD,DO S DA(1)=RMPOXITE,DIC="^RMPR(669.9,"_RMPOXITE_","_""""_RMCOD_""""_","
S DIC(0)="L",X=RMPODFN,DLAYGO=669.9 D FILE^DICN
I '$D(DA) W !,"Patient was not added!!!" Q
S RMPOLTR=$G(LTRX("C",RMPOLCD))
S ^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_DA
K DIC,DA,X
;
AMEND ; delete listman data and rebuild list from amended work file
D CLEAN^VALM10,INIT
Q:'$D(@VALMAR) ; Quit if there are no entries in list
S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOLG 4417 printed Oct 16, 2024@18:31:43 Page 2
RMPOLG ;HIN-CIOFO/RVD - HOME OXYGEN LETTERS (MANAGE LETTER) ;7/24/98
+1 ;;3.0;PROSTHETICS;**29,46**;Feb 09, 1996
EN ; -- main entry point for manage letter list.
+1 ; Input:
+2 ; RMPOLCD - Selected Home Oxygen Letter code
+3 ; Called by:
+4 ; RMPOLZ - H.O. Letter Control module
+5 DO EN^VALM("RMPO MANAGE LETTER")
+6 QUIT
+7 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$$CNTR^RMPOLY(" ",$$EXTERNAL^DILFD(669.965,1,"",RMPOLCD),80)
+2 SET VALMHDR(2)=$$CNTR^RMPOLY(" ","HOME OXYGEN PATIENT LETTER LIST",80)
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 NEW RMPODFN,REC,RMPOITEM,Y,X,SP
+2 ;
+3 ; for each entry in list for the selected letter type display details
+4 SET RMPONAM=""
SET VALMCNT=0
SET $PIECE(SP," ",80)=" "
+5 FOR
SET RMPONAM=$ORDER(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM))
if RMPONAM=""
QUIT
Begin DoDot:1
+6 SET RMPODFN=$PIECE(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,2)
+7 SET REC=^TMP($JOB,RMPOXITE,"RMPODEMO",RMPODFN)
SET VALMCNT=VALMCNT+1
+8 SET Y=$PIECE(REC,U,3)
DO DD^%DT
SET RMPORX=Y
SET Y=$PIECE(REC,U,4)
+9 IF Y'=""
DO DD^%DT
+10 IF Y=""
SET Y="No Rx!"
+11 SET RMPOEXP=Y
SET RMPOITEM=$PIECE(REC,U,5)
+12 if RMPOITEM=""
SET RMPOITEM="No Primary!"
+13 ;
+14 SET X=$$SETFLD^VALM1($EXTRACT(VALMCNT_SP,1,$PIECE(VALMDDF("LINE #"),U,3)),"","LINE #")
+15 SET X=$$SETFLD^VALM1($PIECE($PIECE(REC,U),","),X,"PATIENT")
+16 SET X=$$SETFLD^VALM1($PIECE(REC,U,2),X,"SSN")
+17 SET X=$$SETFLD^VALM1(RMPOITEM,X,"PRIMARY ITEM")
+18 SET X=$$SETFLD^VALM1(RMPORX,X,"ACTIVATION DATE")
+19 SET X=$$SETFLD^VALM1(RMPOEXP,X,"Rx EXPIRY DATE")
+20 DO SET^VALM10(VALMCNT,X,RMPODFN)
End DoDot:1
+21 QUIT
+22 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO CLEAN^VALM10
+2 QUIT
+3 ;
EN02 ; Delete list entry and code deleted in #665
+1 NEW SEL,LINE
+2 ; Select lines to delete
+3 SET SEL=$$SELN^RMPOLZA("L","Enter lines to delete",VALMCNT)
+4 ; quit to menu
IF SEL="^"
SET ^TMP($JOB,RMPOXITE,"EXIT")=1
QUIT
+5 if 'SEL
QUIT
+6 NEW CNT
+7 ; for each patient selected remove 'Letter to be sent' from
+8 ; Prosthetics Patient File (665)
+9 FOR CNT=1:1
SET LINE=$PIECE(SEL,",",CNT)
if LINE=""
QUIT
Begin DoDot:1
+10 SET RMPODFN=$ORDER(@VALMAR@("IDX",LINE,""))
+11 SET RMPONAM=$PIECE(^TMP($JOB,RMPOXITE,"RMPODEMO",RMPODFN),U,1)
+12 SET RMPONAM=$EXTRACT(RMPONAM,1,15)
+13 DO UPDLTR^RMPOLZA(RMPODFN,"@")
+14 ; purge work file holding data
+15 KILL ^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),^TMP($JOB,RMPOXITE,"RMPODEMO",RMPODFN)
+16 if '$DATA(RMPOLCD)
QUIT
+17 IF RMPOLCD="A"
Begin DoDot:2
+18 SET $PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,09)=DT
SET $PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,10)="D"
+19 SET RMDBAT="RMPOXBAT1"
End DoDot:2
+20 IF RMPOLCD="B"
Begin DoDot:2
+21 SET $PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,11)=DT
SET $PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,12)="D"
+22 SET RMDBAT="RMPOXBAT2"
End DoDot:2
+23 IF RMPOLCD="C"
Begin DoDot:2
+24 SET $PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,13)=DT
SET $PIECE(^RMPR(665,RMPODFN,"RMPOA"),U,14)="D"
+25 SET RMDBAT="RMPOXBAT3"
End DoDot:2
+26 SET DA=$ORDER(^RMPR(669.9,RMPOXITE,RMDBAT,"B",RMPODFN,0))
+27 SET DIK="^RMPR(669.9,"_RMPOXITE_","
SET DA(1)=RMPOXITE
+28 SET DIK=DIK_""""_RMDBAT_""""_","
DO ^DIK
End DoDot:1
+29 KILL DIK,DA
+30 ;
+31 GOTO AMEND
+32 ;
ADD ; Add patient to the list entry.
+1 DO FULL^VALM1
WRITE @IOF
+2 KILL DIC,RMPODFN
+3 SET DIC("S")="I '$D(^TMP($J,RMPOXITE,""RMPODEMO"",+Y)),$D(^RMPR(665,+Y,""RMPOA"")),$P(^(""RMPOA""),U,3)="""",$P(^(0),U,2)=RMPOSITE"
DIC SET DIC="^RMPR(665,"
SET DIC(0)="EAMQN"
DO ^DIC
IF Y<0
GOTO AMEND
+1 SET RMPORX=$PIECE($GET(^RMPR(665,+Y,"RMPOB",0)),U,3)
if '$GET(RMPORX)
GOTO DIC
+2 IF $GET(RMPORX)
IF '$DATA(^RMPR(665,+Y,"RMPOB",RMPORX,0))
WRITE !,"Patient has no current prescription!!"
GOTO DIC
+3 SET RMDEXP=$PIECE(^RMPR(665,+Y,"RMPOB",RMPORX,0),U,3)
+4 IF RMPORX
IF RMDEXP
IF RMDEXP<DT
WRITE !,"Rx prescription has expired - Unable to ADD patient to the list !!",!
GOTO DIC
+5 SET RMPODFN=+Y
SET ADT=$PIECE($GET(^RMPR(665,+Y,"RMPOA")),U,2)
+6 ;
GETPAT ;get patient information(demographics)
+1 DO EXTRCT^RMPOLZA
+2 SET RMPONAM=$PIECE(^TMP($JOB,RMPOXITE,"RMPODEMO",RMPODFN),U,1)
+3 ;S RMI="",RMPOLTR=0 F S RMI=$O(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMI)) Q:RMI="" S RMPOLTR=$P(^(RMI),U,1)
+4 SET RMCOD=$SELECT(RMPOLCD="A":"RMPOXBAT1",RMPOLCD="B":"RMPOXBAT2",RMPOLCD="C":"RMPOXBAT3",1:"")
+5 ;add the code to delete the entry in 665 for P and D entries and the dates.
+6 if $DATA(^RMPR(669.9,RMPOXITE,RMCOD,"B",RMPODFN))
QUIT
+7 KILL DD,DO
SET DA(1)=RMPOXITE
SET DIC="^RMPR(669.9,"_RMPOXITE_","_""""_RMCOD_""""_","
+8 SET DIC(0)="L"
SET X=RMPODFN
SET DLAYGO=669.9
DO FILE^DICN
+9 IF '$DATA(DA)
WRITE !,"Patient was not added!!!"
QUIT
+10 SET RMPOLTR=$GET(LTRX("C",RMPOLCD))
+11 SET ^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)=RMPOLTR_"^"_RMPODFN_"^"_DA
+12 KILL DIC,DA,X
+13 ;
AMEND ; delete listman data and rebuild list from amended work file
+1 DO CLEAN^VALM10
DO INIT
+2 ; Quit if there are no entries in list
if '$DATA(@VALMAR)
QUIT
+3 SET VALMBCK="R"
+4 QUIT
