RMPOLY ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
;;3.0;PROSTHETICS;**29**;Feb 09, 1996
;
EN ; -- main entry point for RMPO LETTER TYPE
;
; Input: None
;
; Output:
; RMPOLCD - H.O. Letter Type code
;
; Called by:
; RMPOLZ - H.O. Letter Control module
;
N LSTN
;
D EN^VALM("RMPO LETTER TYPE")
Q
;
HDR ; -- header code
;
S VALMHDR(1)=$$CNTR(" ",RMPO("NAME"),80)
S VALMHDR(2)=$$CNTR(" ","HOME OXYGEN PATIENT LETTER TYPE LIST",80)
Q
;
INIT ; -- init variables and list array
N SP,RMPOLCD,CNT,X,RMPOLTR,LTR
;
S $P(SP," ",80)=" "
;
; initialise list
S (PATV,VALMCNT,RMPOLCD,CNT)=0
; for each valid H.O. letter type code define a line
F S RMPOLCD=$O(LTRX("A",RMPOLCD)) Q:RMPOLCD="" D
. S VALMCNT=VALMCNT+1,LSTN(VALMCNT)=RMPOLCD
. S CNT=0,RMPONAM=""
. F S RMPONAM=$O(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM)) Q:RMPONAM="" D
. . S CNT=CNT+1
. . S RMPOLTR=$P(^TMP($J,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1),RMPODFN=$P(^(RMPONAM),U,2)
. . S LTR=$P(^RMPR(665.2,RMPOLTR,0),U)
. . D UPDLTR^RMPOLET0(RMPODFN,LTR) ; update "letter to be sent" flag for patient
. ;
. S X=$$SETFLD^VALM1($E(VALMCNT_SP,1,$P(VALMDDF("LINE #"),U,3)),"","LINE #")
. S X=$$SETFLD^VALM1($$EXTERNAL^DILFD(669.965,1,"",RMPOLCD),X,"DESCRIPTION")
. S X=$$SETFLD^VALM1(CNT,X,"PATIENT COUNT")
. D SET^VALM10(VALMCNT,X,CNT) ; create list line
. S:CNT PATV=1 ; at least one line have a patient count value > 0
;
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D CLEAN^VALM10
K LSTN,PATV
;
Q
;
EXPND ; -- expand code
Q
;
EN01 ; Select letter type
N Y
S VALMBCK="R",LST=0
;I 'PATV S VALMSG="There are no patients awaiting a letter" Q
S Y=$$SELN^RMPOLZA("N","Select letter type line #",VALMCNT) Q:'Y
I $G(^TMP($J,RMPOXITE,"EXIT"))=1 S QT=1 Q
S VALMBCK="Q"
S (RMPOLCD,RMC)=LSTN(Y)
S RMBAT=$S(RMC="A":"RMPOXBAT1",RMC="B":"RMPOXBAT2",RMC="C":"RMPOXBAT3",1:"")
S RMBATCO=$S(RMC="A":"^669.9002P^^",RMC="B":"^669.972P^^",RMC="C":"^669.974P^^^",1:"")
;K ^RMPR(669.9,RMPOXITE,RMBAT) S ^RMPR(669.9,RMPOXITE,RMBAT,0)=RMBATCO
D NEWLST^RMPOLZ
I $O(^RMPR(669.9,RMPOXITE,RMBAT,0))'>0 S VALMSG="No patients are awaiting letters of this type!!" H 4 W !,VALMSG Q
W !,"DONE GENERATING A NEW LIST..." H 4
; rebuild letter type list.
D CLEAN^VALM10,INIT^RMPOLY S VALMBCK="R",RMPOLCD=""
Q
;
EN02 ; Print letters
; select letter type. Quit if none choosen
;D EN01^RMPOLY S VALMBCK="R" Q:RMPOLCD=""
N Y
S VALMBCK="R"
I 'PATV S VALMSG="There are no patients awaiting a letter" Q
;
S Y=$$SELN^RMPOLZA("N","Select letter type line #",VALMCNT) Q:'Y
W !,$C(7),"Processing...."
I '$O(@VALMAR@("IDX",Y,"")) S VALMSG="No patients are awaiting letters of this type!!" H 4 W !,VALMSG Q
S VALMBCK="Q",RMPOLCD=LSTN(Y)
;ask for patient to print
D EN^RMPOLT
; rebuild letter type list.
D CLEAN^VALM10,INIT^RMPOLY S VALMBCK="R",RMPOLCD=""
Q
;
CNTR(PD,TXT,WDT) ; Centre text
S $P(PD,PD,WDT)=PD
Q $E(PD,1,(WDT-$L(TXT))/2)_TXT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOLY 3092 printed Apr 09, 2024@21:39:53 Page 2
RMPOLY ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
+1 ;;3.0;PROSTHETICS;**29**;Feb 09, 1996
+2 ;
EN ; -- main entry point for RMPO LETTER TYPE
+1 ;
+2 ; Input: None
+3 ;
+4 ; Output:
+5 ; RMPOLCD - H.O. Letter Type code
+6 ;
+7 ; Called by:
+8 ; RMPOLZ - H.O. Letter Control module
+9 ;
+10 NEW LSTN
+11 ;
+12 DO EN^VALM("RMPO LETTER TYPE")
+13 QUIT
+14 ;
HDR ; -- header code
+1 ;
+2 SET VALMHDR(1)=$$CNTR(" ",RMPO("NAME"),80)
+3 SET VALMHDR(2)=$$CNTR(" ","HOME OXYGEN PATIENT LETTER TYPE LIST",80)
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 NEW SP,RMPOLCD,CNT,X,RMPOLTR,LTR
+2 ;
+3 SET $PIECE(SP," ",80)=" "
+4 ;
+5 ; initialise list
+6 SET (PATV,VALMCNT,RMPOLCD,CNT)=0
+7 ; for each valid H.O. letter type code define a line
+8 FOR
SET RMPOLCD=$ORDER(LTRX("A",RMPOLCD))
if RMPOLCD=""
QUIT
Begin DoDot:1
+9 SET VALMCNT=VALMCNT+1
SET LSTN(VALMCNT)=RMPOLCD
+10 SET CNT=0
SET RMPONAM=""
+11 FOR
SET RMPONAM=$ORDER(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM))
if RMPONAM=""
QUIT
Begin DoDot:2
+12 SET CNT=CNT+1
+13 SET RMPOLTR=$PIECE(^TMP($JOB,RMPOXITE,"RMPOLST",RMPOLCD,RMPONAM),U,1)
SET RMPODFN=$PIECE(^(RMPONAM),U,2)
+14 SET LTR=$PIECE(^RMPR(665.2,RMPOLTR,0),U)
+15 ; update "letter to be sent" flag for patient
DO UPDLTR^RMPOLET0(RMPODFN,LTR)
End DoDot:2
+16 ;
+17 SET X=$$SETFLD^VALM1($EXTRACT(VALMCNT_SP,1,$PIECE(VALMDDF("LINE #"),U,3)),"","LINE #")
+18 SET X=$$SETFLD^VALM1($$EXTERNAL^DILFD(669.965,1,"",RMPOLCD),X,"DESCRIPTION")
+19 SET X=$$SETFLD^VALM1(CNT,X,"PATIENT COUNT")
+20 ; create list line
DO SET^VALM10(VALMCNT,X,CNT)
+21 ; at least one line have a patient count value > 0
if CNT
SET PATV=1
End DoDot:1
+22 ;
+23 QUIT
+24 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO CLEAN^VALM10
+2 KILL LSTN,PATV
+3 ;
+4 QUIT
+5 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
EN01 ; Select letter type
+1 NEW Y
+2 SET VALMBCK="R"
SET LST=0
+3 ;I 'PATV S VALMSG="There are no patients awaiting a letter" Q
+4 SET Y=$$SELN^RMPOLZA("N","Select letter type line #",VALMCNT)
if 'Y
QUIT
+5 IF $GET(^TMP($JOB,RMPOXITE,"EXIT"))=1
SET QT=1
QUIT
+6 SET VALMBCK="Q"
+7 SET (RMPOLCD,RMC)=LSTN(Y)
+8 SET RMBAT=$SELECT(RMC="A":"RMPOXBAT1",RMC="B":"RMPOXBAT2",RMC="C":"RMPOXBAT3",1:"")
+9 SET RMBATCO=$SELECT(RMC="A":"^669.9002P^^",RMC="B":"^669.972P^^",RMC="C":"^669.974P^^^",1:"")
+10 ;K ^RMPR(669.9,RMPOXITE,RMBAT) S ^RMPR(669.9,RMPOXITE,RMBAT,0)=RMBATCO
+11 DO NEWLST^RMPOLZ
+12 IF $ORDER(^RMPR(669.9,RMPOXITE,RMBAT,0))'>0
SET VALMSG="No patients are awaiting letters of this type!!"
HANG 4
WRITE !,VALMSG
QUIT
+13 WRITE !,"DONE GENERATING A NEW LIST..."
HANG 4
+14 ; rebuild letter type list.
+15 DO CLEAN^VALM10
DO INIT^RMPOLY
SET VALMBCK="R"
SET RMPOLCD=""
+16 QUIT
+17 ;
EN02 ; Print letters
+1 ; select letter type. Quit if none choosen
+2 ;D EN01^RMPOLY S VALMBCK="R" Q:RMPOLCD=""
+3 NEW Y
+4 SET VALMBCK="R"
+5 IF 'PATV
SET VALMSG="There are no patients awaiting a letter"
QUIT
+6 ;
+7 SET Y=$$SELN^RMPOLZA("N","Select letter type line #",VALMCNT)
if 'Y
QUIT
+8 WRITE !,$CHAR(7),"Processing...."
+9 IF '$ORDER(@VALMAR@("IDX",Y,""))
SET VALMSG="No patients are awaiting letters of this type!!"
HANG 4
WRITE !,VALMSG
QUIT
+10 SET VALMBCK="Q"
SET RMPOLCD=LSTN(Y)
+11 ;ask for patient to print
+12 DO EN^RMPOLT
+13 ; rebuild letter type list.
+14 DO CLEAN^VALM10
DO INIT^RMPOLY
SET VALMBCK="R"
SET RMPOLCD=""
+15 QUIT
+16 ;
CNTR(PD,TXT,WDT) ; Centre text
+1 SET $PIECE(PD,PD,WDT)=PD
+2 QUIT $EXTRACT(PD,1,(WDT-$LENGTH(TXT))/2)_TXT
