- RMPOLZC ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
- ;;3.0;PROSTHETICS;**55**;Feb 09, 1996
- ;
- ; ODJ - patch 55 - Need to split RMPOLZ as over 10K
- ;
- Q
- ;
- LST ; Check Letters List
- ; Input:
- ; JOB - 1: job, 0: interactive
- ; Output:
- ; LST(list parameters) - 0: no action
- ; 1: use current list
- ; 2: create new list
- S (RL,RMLSTF,LST)=0,%=2
- S RMBAT1=$O(^RMPR(669.9,RMPOXITE,"RMPOXBAT1",0))
- S RMBAT2=$O(^RMPR(669.9,RMPOXITE,"RMPOXBAT2",0))
- S RMBAT3=$O(^RMPR(669.9,RMPOXITE,"RMPOXBAT3",0))
- I $G(RMBAT1)!$G(RMBAT2)!$G(RMBAT3) S RMLSTF=1 ; if already a patient list in existance exit
- I JOB S LST=1 Q ; use current list as default if run in background
- LST1 I RMLSTF W !,"A list of patient letters to be printed already exists",!,"Do you wish to manage the current list" D YN^DICN
- S:%=1 LST=1 S:%=-1 LST=0 S:%=2 RL=2 I %=0 W !,"Answer with 'Y' or 'N' " S %=2 G LST1
- LST2 I RL=2 S %=2 W !,"Do you wish to generate a new list which will discard any edits" D YN^DICN S:%=1 LST=1 S:%=2 LST=2 S:%=-1 LST=0 I %=0 W !,"Answer with 'Y' or 'N' " S %=2 G LST2
- Q
- ;
- PURGE ; Purge current patient letter list
- S RMPOLTR=0 F S RMPOLTR=$O(^RMPR(665,"ALTR",RMPOLTR)) Q:RMPOLTR="" D
- . S RMPODFN=0 F S RMPODFN=$O(^RMPR(665,"ALTR",RMPOLTR,RMPODFN)) Q:RMPODFN="" D UPDLTR^RMPOLZA(RMPODFN,"@")
- Q
- ;
- LTRCR() ; build local array CROSS REFERENCE of H.O. letter Code to Letter
- ; ! assumes a letter code can have many letter templates but one !
- ; ! template is of a particluar type e.g. a 30,60,90 & 120 Day H.O. !
- ; ! letters are all of type "B" : prescription pending expiry. !
- ; Input:
- ; JOB - 1: job, 0: interactive
- ; Output:
- ; LTRX("A",Letter Code,Prosthetics Letter IEN)
- ; LTRX("B",Prosthetics Letter IEN)=Letter Code
- ; LTRX("C",Letter Code)=Prosthetics Letter IEN
- ; LTRX("D",Letter Code)=days till expiry (patch 55)
- ; ^TMP($J,RMPOXITE,"HEADER",RMPOLTR)= 0: No Letter header
- N LTRIEN,REC,HEAD,X1,X2,X,%H,%T,%,%I,RMPONOW
- D NOW^%DTC S RMPONOW=X
- S LTRIEN=0 F S LTRIEN=$O(^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN)) Q:LTRIEN<1 D
- . S REC=^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN,0)
- . ; if run is backgrd and letters are NOT to be autogenerated then do not list
- . ; the letter as a valid H.O. letter
- . I JOB,'$P(REC,U,4) Q
- . S RMPOLTR=$P(REC,U),RMPOLCD=$P(REC,U,2),RMPOGEN=$P(REC,U,4)
- . I RMPOLCD=""!(RMPOLTR="")!('$G(RMPOGEN)) Q
- . S ^TMP($J,RMPOXITE,"HEADER",RMPOLTR)=$P(REC,U,5)
- . S LTRX("A",RMPOLCD,RMPOLTR)="",LTRX("B",RMPOLTR)=RMPOLCD
- . S LTRX("C",RMPOLCD)=RMPOLTR
- . ;
- . ; calc. a date after which prescription expiry dates will
- . ; not generate a given letter
- . S X1=RMPONOW,X2=$P(REC,U,3) D C^%DTC
- . S LTRX("D",RMPOLCD)=X
- Q
- ;
- ; Get active prescription
- RXAC(RMPRPAT) ;
- N RMPRX,RMPRS,X,%,%H,%I,RMPROK,RMDACT,RMDEXP,TODAY,RMPRIEN
- D NOW^%DTC
- S TODAY=X
- S RMPRIEN=0
- S RMPRX=":"
- F S RMPRX=$O(^RMPR(665,RMPRPAT,"RMPOB",RMPRX),-1) Q:'+RMPRX D Q:RMPRIEN
- . S RMPRS=^RMPR(665,RMPRPAT,"RMPOB",RMPRX,0)
- . S RMDACT=$P(RMPRS,"^",1)
- . S RMDEXP=$P(RMPRS,"^",3)
- . I RMDACT'="",RMDACT'>TODAY D
- .. I RMDEXP="" S RMPRIEN=RMPRX Q
- .. I RMDEXP>TODAY S RMPRIEN=RMPRX Q
- .. Q
- . Q
- Q RMPRIEN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOLZC 3310 printed Feb 18, 2025@23:57:39 Page 2
- RMPOLZC ;EDS/PAK - HOME OXYGEN LETTERS ;7/24/98
- +1 ;;3.0;PROSTHETICS;**55**;Feb 09, 1996
- +2 ;
- +3 ; ODJ - patch 55 - Need to split RMPOLZ as over 10K
- +4 ;
- +5 QUIT
- +6 ;
- LST ; Check Letters List
- +1 ; Input:
- +2 ; JOB - 1: job, 0: interactive
- +3 ; Output:
- +4 ; LST(list parameters) - 0: no action
- +5 ; 1: use current list
- +6 ; 2: create new list
- +7 SET (RL,RMLSTF,LST)=0
- SET %=2
- +8 SET RMBAT1=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOXBAT1",0))
- +9 SET RMBAT2=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOXBAT2",0))
- +10 SET RMBAT3=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOXBAT3",0))
- +11 ; if already a patient list in existance exit
- IF $GET(RMBAT1)!$GET(RMBAT2)!$GET(RMBAT3)
- SET RMLSTF=1
- +12 ; use current list as default if run in background
- IF JOB
- SET LST=1
- QUIT
- LST1 IF RMLSTF
- WRITE !,"A list of patient letters to be printed already exists",!,"Do you wish to manage the current list"
- DO YN^DICN
- +1 if %=1
- SET LST=1
- if %=-1
- SET LST=0
- if %=2
- SET RL=2
- IF %=0
- WRITE !,"Answer with 'Y' or 'N' "
- SET %=2
- GOTO LST1
- LST2 IF RL=2
- SET %=2
- WRITE !,"Do you wish to generate a new list which will discard any edits"
- DO YN^DICN
- if %=1
- SET LST=1
- if %=2
- SET LST=2
- if %=-1
- SET LST=0
- IF %=0
- WRITE !,"Answer with 'Y' or 'N' "
- SET %=2
- GOTO LST2
- +1 QUIT
- +2 ;
- PURGE ; Purge current patient letter list
- +1 SET RMPOLTR=0
- FOR
- SET RMPOLTR=$ORDER(^RMPR(665,"ALTR",RMPOLTR))
- if RMPOLTR=""
- QUIT
- Begin DoDot:1
- +2 SET RMPODFN=0
- FOR
- SET RMPODFN=$ORDER(^RMPR(665,"ALTR",RMPOLTR,RMPODFN))
- if RMPODFN=""
- QUIT
- DO UPDLTR^RMPOLZA(RMPODFN,"@")
- End DoDot:1
- +3 QUIT
- +4 ;
- LTRCR() ; build local array CROSS REFERENCE of H.O. letter Code to Letter
- +1 ; ! assumes a letter code can have many letter templates but one !
- +2 ; ! template is of a particluar type e.g. a 30,60,90 & 120 Day H.O. !
- +3 ; ! letters are all of type "B" : prescription pending expiry. !
- +4 ; Input:
- +5 ; JOB - 1: job, 0: interactive
- +6 ; Output:
- +7 ; LTRX("A",Letter Code,Prosthetics Letter IEN)
- +8 ; LTRX("B",Prosthetics Letter IEN)=Letter Code
- +9 ; LTRX("C",Letter Code)=Prosthetics Letter IEN
- +10 ; LTRX("D",Letter Code)=days till expiry (patch 55)
- +11 ; ^TMP($J,RMPOXITE,"HEADER",RMPOLTR)= 0: No Letter header
- +12 NEW LTRIEN,REC,HEAD,X1,X2,X,%H,%T,%,%I,RMPONOW
- +13 DO NOW^%DTC
- SET RMPONOW=X
- +14 SET LTRIEN=0
- FOR
- SET LTRIEN=$ORDER(^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN))
- if LTRIEN<1
- QUIT
- Begin DoDot:1
- +15 SET REC=^RMPR(669.9,RMPOXITE,"RMPOLET",LTRIEN,0)
- +16 ; if run is backgrd and letters are NOT to be autogenerated then do not list
- +17 ; the letter as a valid H.O. letter
- +18 IF JOB
- IF '$PIECE(REC,U,4)
- QUIT
- +19 SET RMPOLTR=$PIECE(REC,U)
- SET RMPOLCD=$PIECE(REC,U,2)
- SET RMPOGEN=$PIECE(REC,U,4)
- +20 IF RMPOLCD=""!(RMPOLTR="")!('$GET(RMPOGEN))
- QUIT
- +21 SET ^TMP($JOB,RMPOXITE,"HEADER",RMPOLTR)=$PIECE(REC,U,5)
- +22 SET LTRX("A",RMPOLCD,RMPOLTR)=""
- SET LTRX("B",RMPOLTR)=RMPOLCD
- +23 SET LTRX("C",RMPOLCD)=RMPOLTR
- +24 ;
- +25 ; calc. a date after which prescription expiry dates will
- +26 ; not generate a given letter
- +27 SET X1=RMPONOW
- SET X2=$PIECE(REC,U,3)
- DO C^%DTC
- +28 SET LTRX("D",RMPOLCD)=X
- End DoDot:1
- +29 QUIT
- +30 ;
- +31 ; Get active prescription
- RXAC(RMPRPAT) ;
- +1 NEW RMPRX,RMPRS,X,%,%H,%I,RMPROK,RMDACT,RMDEXP,TODAY,RMPRIEN
- +2 DO NOW^%DTC
- +3 SET TODAY=X
- +4 SET RMPRIEN=0
- +5 SET RMPRX=":"
- +6 FOR
- SET RMPRX=$ORDER(^RMPR(665,RMPRPAT,"RMPOB",RMPRX),-1)
- if '+RMPRX
- QUIT
- Begin DoDot:1
- +7 SET RMPRS=^RMPR(665,RMPRPAT,"RMPOB",RMPRX,0)
- +8 SET RMDACT=$PIECE(RMPRS,"^",1)
- +9 SET RMDEXP=$PIECE(RMPRS,"^",3)
- +10 IF RMDACT'=""
- IF RMDACT'>TODAY
- Begin DoDot:2
- +11 IF RMDEXP=""
- SET RMPRIEN=RMPRX
- QUIT
- +12 IF RMDEXP>TODAY
- SET RMPRIEN=RMPRX
- QUIT
- +13 QUIT
- End DoDot:2
- +14 QUIT
- End DoDot:1
- if RMPRIEN
- QUIT
- +15 QUIT RMPRIEN