RMPR5HQ7 ;HCIOFO/ODJ - INVENTORY ROLL UP - CREATE ^TMP GLOBAL FOR MAILING ; 20 SEP 00
;;3.0;PROSTHETICS;**51**;Feb 09, 1996
Q
;
; Required vars are
; RMPRSDT
; RMPREDT
MAIL N KEYS,EOF,LINE,STR,TSTR,GROUP,CHNG,TNAM,USTR
S TNAM="RMPR5A"
K ^TMP($J,TNAM)
D GRPARY^RMPR5HQ4(.GROUP)
D INIT^RMPR5HQ6(.KEYS,.EOF,.CHNG)
I EOF G MAILX
S TSTR=""
S $P(TSTR,"^",3)=$E(RMPRSDT,4,5)_"/"_$E(RMPRSDT,6,7)_"/"_(1700+$E(RMPRSDT,1,3))
S $P(TSTR,"^",4)=$E(RMPREDT,4,5)_"/"_$E(RMPREDT,6,7)_"/"_(1700+$E(RMPREDT,1,3))
S LINE=0
F D Q:EOF
. I CHNG("STATION") D
.. S $P(TSTR,"^",2)=$P($G(^DIC(4,KEYS("STATION"),0)),"^",1)
.. S I=$O(^RMPR(669.9,"C",KEYS("STATION"),"")) Q:I=""
.. S $P(TSTR,"^",1)=$P($G(^RMPR(669.9,I,"INV")),"^",2) ;VISN
.. Q
. I CHNG("NPPD_GROUP") S $P(TSTR,"^",5)=GROUP(KEYS("NPPD_GROUP"))
. I CHNG("NPPD_LINE") S $P(TSTR,"^",6)=KEYS("NPPD_LINE")_" "_$$NPLIN^RMPR5HQ5(KEYS("NPPD_LINE"))
. ;I CHNG("HCPC_CODE") S $P(TSTR,"^",7)=$$GETITEM^RMPR5HQ5(KEYS("HCPC_IEN"),"")
. I CHNG("HCPC_CODE") S $P(TSTR,"^",7)=KEYS("HCPC_CODE")
. D RDHCPC(.KEYS,.STR) S:'+$P(STR,"^",3) $P(STR,"^",3)=""
. I $L(STR,"^")<13 S $P(STR,"^",13)=""
. F I=6,12 S:+$P(STR,"^",I) $P(STR,"^",I)=$J($P(STR,"^",I),0,2)
. F I=7,13 S:+$P(STR,"^",I) $P(STR,"^",I)=$J($P(STR,"^",I),0,1)
. I (+$P(STR,"^",1)&+$P(STR,"^",2))!(+$P(STR,"^",8)&+$P(STR,"^",9)) D
.. S USTR=STR
.. F I=2,5,6,7,9,11 S $P(USTR,"^",I)=""
.. F I=1,4,8,10,12,13 S $P(STR,"^",I)=""
.. S LINE=LINE+1
.. D MAP(USTR,.TSTR)
.. S ^TMP($J,TNAM,LINE)=TSTR
.. S TSTR=$P(TSTR,"^",1,7)
.. Q
. S LINE=LINE+1
. D MAP(STR,.TSTR)
. S ^TMP($J,TNAM,LINE)=TSTR
. S TSTR=$P(TSTR,"^",1,7)
. D NXHCPC(.KEYS,.EOF,.CHNG)
. Q
MAILX Q
;
; Read HCPC level in ^TMP
RDHCPC(PRIKEY,MYSTR) ;
N TNAM,STATION,NPGRP,NPLIN,HCPC
S TNAM="RMPR5"
S STATION=PRIKEY("STATION")
S NPGRP=PRIKEY("NPPD_GROUP")
S NPLIN=PRIKEY("NPPD_LINE")
S HCPC=PRIKEY("HCPC")
S MYSTR=$G(^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPC))
Q
;
; Get next HCPC code
NXHCPC(RMPRKEY,RMPREOF,RMPRCHNG) ;
N TNAM,NPGRP,NPLIN,HCPC,ITEM,INVIEN,STATION
S TNAM="RMPR5"
S STATION=RMPRKEY("STATION")
S NPGRP=RMPRKEY("NPPD_GROUP")
S NPLIN=RMPRKEY("NPPD_LINE")
S HCPC=RMPRKEY("HCPC")
S RMPRCHNG("STATION")=0
S RMPREOF=0,RMPRCHNG("NPPD_GROUP")=0,RMPRCHNG("NPPD_LINE")=0
S HCPC=$O(^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPC))
S:HCPC="" NPLIN=$O(^TMP($J,TNAM,STATION,NPGRP,NPLIN))
S:NPLIN="" NPGRP=$O(^TMP($J,TNAM,STATION,NPGRP))
S:NPGRP="" STATION=$O(^TMP($J,TNAM,STATION))
I STATION=""!(STATION="Z") S RMPREOF=1,RMPRCHNG("HCPC_CODE")=0,RMPRCHNG("HCPC_ITEM")=0,RMPRCHNG("INVENTORY_IEN")=0 G NXHCPCX
S:NPGRP="" NPGRP=$O(^TMP($J,TNAM,STATION,"")),RMPRCHNG("STATION")=1
S:NPLIN="" NPLIN=$O(^TMP($J,TNAM,STATION,NPGRP,"")),RMPRCHNG("NPPD_GROUP")=1
S:HCPC="" HCPC=$O(^TMP($J,TNAM,STATION,NPGRP,NPLIN,"")),RMPRCHNG("NPPD_LINE")=1
S RMPRCHNG("HCPC_CODE")=1
S ITEM=$O(^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPC,""))
S RMPRCHNG("HCPC_ITEM")=1
S INVIEN=$O(^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPC,ITEM,""))
S RMPRCHNG("INVENTORY_IEN")=1
S RMPRKEY("STATION")=STATION
S RMPRKEY("NPPD_GROUP")=NPGRP
S RMPRKEY("NPPD_LINE")=NPLIN
S RMPRKEY("HCPC")=HCPC
S RMPRKEY("HCPC_CODE")=$P(HCPC,"/",1)
S RMPRKEY("HCPC_IEN")=$P(HCPC,"/",2)
S RMPRKEY("HCPC_ITEM")=ITEM
S RMPRKEY("INVENTORY_IEN")=INVIEN
NXHCPCX Q
MAP(CALC,RUP) ;
S $P(RUP,"^",8)=$P(CALC,"^",2)
S $P(RUP,"^",9)=$P(CALC,"^",5)
S:+$P(RUP,"^",8) $P(RUP,"^",10)=$J($P(RUP,"^",9)/$P(RUP,"^",8),0,2)
S $P(RUP,"^",11)=$P(CALC,"^",6)
S $P(RUP,"^",12)=$P(CALC,"^",7)
S $P(RUP,"^",13)=$P(CALC,"^",9)
S $P(RUP,"^",14)=$P(CALC,"^",11)
S:+$P(RUP,"^",13) $P(RUP,"^",15)=$J($P(RUP,"^",14)/$P(RUP,"^",13),0,2)
S $P(RUP,"^",16)=$P(CALC,"^",1)
S $P(RUP,"^",17)=$P(CALC,"^",4)
S:+$P(RUP,"^",16) $P(RUP,"^",18)=$J($P(RUP,"^",17)/$P(RUP,"^",16),0,2)
S $P(RUP,"^",19)=$P(CALC,"^",12)
S $P(RUP,"^",20)=$P(CALC,"^",13)
S $P(RUP,"^",21)=$P(CALC,"^",8)
S $P(RUP,"^",22)=$P(CALC,"^",10)
S:+$P(RUP,"^",21) $P(RUP,"^",23)=$J($P(RUP,"^",22)/$P(RUP,"^",21),0,2)
S $P(RUP,"^",24)=$G(RMCALDAY)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5HQ7 4137 printed Sep 23, 2025@20:09:12 Page 2
RMPR5HQ7 ;HCIOFO/ODJ - INVENTORY ROLL UP - CREATE ^TMP GLOBAL FOR MAILING ; 20 SEP 00
+1 ;;3.0;PROSTHETICS;**51**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ; Required vars are
+5 ; RMPRSDT
+6 ; RMPREDT
MAIL NEW KEYS,EOF,LINE,STR,TSTR,GROUP,CHNG,TNAM,USTR
+1 SET TNAM="RMPR5A"
+2 KILL ^TMP($JOB,TNAM)
+3 DO GRPARY^RMPR5HQ4(.GROUP)
+4 DO INIT^RMPR5HQ6(.KEYS,.EOF,.CHNG)
+5 IF EOF
GOTO MAILX
+6 SET TSTR=""
+7 SET $PIECE(TSTR,"^",3)=$EXTRACT(RMPRSDT,4,5)_"/"_$EXTRACT(RMPRSDT,6,7)_"/"_(1700+$EXTRACT(RMPRSDT,1,3))
+8 SET $PIECE(TSTR,"^",4)=$EXTRACT(RMPREDT,4,5)_"/"_$EXTRACT(RMPREDT,6,7)_"/"_(1700+$EXTRACT(RMPREDT,1,3))
+9 SET LINE=0
+10 FOR
Begin DoDot:1
+11 IF CHNG("STATION")
Begin DoDot:2
+12 SET $PIECE(TSTR,"^",2)=$PIECE($GET(^DIC(4,KEYS("STATION"),0)),"^",1)
+13 SET I=$ORDER(^RMPR(669.9,"C",KEYS("STATION"),""))
if I=""
QUIT
+14 ;VISN
SET $PIECE(TSTR,"^",1)=$PIECE($GET(^RMPR(669.9,I,"INV")),"^",2)
+15 QUIT
End DoDot:2
+16 IF CHNG("NPPD_GROUP")
SET $PIECE(TSTR,"^",5)=GROUP(KEYS("NPPD_GROUP"))
+17 IF CHNG("NPPD_LINE")
SET $PIECE(TSTR,"^",6)=KEYS("NPPD_LINE")_" "_$$NPLIN^RMPR5HQ5(KEYS("NPPD_LINE"))
+18 ;I CHNG("HCPC_CODE") S $P(TSTR,"^",7)=$$GETITEM^RMPR5HQ5(KEYS("HCPC_IEN"),"")
+19 IF CHNG("HCPC_CODE")
SET $PIECE(TSTR,"^",7)=KEYS("HCPC_CODE")
+20 DO RDHCPC(.KEYS,.STR)
if '+$PIECE(STR,"^",3)
SET $PIECE(STR,"^",3)=""
+21 IF $LENGTH(STR,"^")<13
SET $PIECE(STR,"^",13)=""
+22 FOR I=6,12
if +$PIECE(STR,"^",I)
SET $PIECE(STR,"^",I)=$JUSTIFY($PIECE(STR,"^",I),0,2)
+23 FOR I=7,13
if +$PIECE(STR,"^",I)
SET $PIECE(STR,"^",I)=$JUSTIFY($PIECE(STR,"^",I),0,1)
+24 IF (+$PIECE(STR,"^",1)&+$PIECE(STR,"^",2))!(+$PIECE(STR,"^",8)&+$PIECE(STR,"^",9))
Begin DoDot:2
+25 SET USTR=STR
+26 FOR I=2,5,6,7,9,11
SET $PIECE(USTR,"^",I)=""
+27 FOR I=1,4,8,10,12,13
SET $PIECE(STR,"^",I)=""
+28 SET LINE=LINE+1
+29 DO MAP(USTR,.TSTR)
+30 SET ^TMP($JOB,TNAM,LINE)=TSTR
+31 SET TSTR=$PIECE(TSTR,"^",1,7)
+32 QUIT
End DoDot:2
+33 SET LINE=LINE+1
+34 DO MAP(STR,.TSTR)
+35 SET ^TMP($JOB,TNAM,LINE)=TSTR
+36 SET TSTR=$PIECE(TSTR,"^",1,7)
+37 DO NXHCPC(.KEYS,.EOF,.CHNG)
+38 QUIT
End DoDot:1
if EOF
QUIT
MAILX QUIT
+1 ;
+2 ; Read HCPC level in ^TMP
RDHCPC(PRIKEY,MYSTR) ;
+1 NEW TNAM,STATION,NPGRP,NPLIN,HCPC
+2 SET TNAM="RMPR5"
+3 SET STATION=PRIKEY("STATION")
+4 SET NPGRP=PRIKEY("NPPD_GROUP")
+5 SET NPLIN=PRIKEY("NPPD_LINE")
+6 SET HCPC=PRIKEY("HCPC")
+7 SET MYSTR=$GET(^TMP($JOB,TNAM,STATION,NPGRP,NPLIN,HCPC))
+8 QUIT
+9 ;
+10 ; Get next HCPC code
NXHCPC(RMPRKEY,RMPREOF,RMPRCHNG) ;
+1 NEW TNAM,NPGRP,NPLIN,HCPC,ITEM,INVIEN,STATION
+2 SET TNAM="RMPR5"
+3 SET STATION=RMPRKEY("STATION")
+4 SET NPGRP=RMPRKEY("NPPD_GROUP")
+5 SET NPLIN=RMPRKEY("NPPD_LINE")
+6 SET HCPC=RMPRKEY("HCPC")
+7 SET RMPRCHNG("STATION")=0
+8 SET RMPREOF=0
SET RMPRCHNG("NPPD_GROUP")=0
SET RMPRCHNG("NPPD_LINE")=0
+9 SET HCPC=$ORDER(^TMP($JOB,TNAM,STATION,NPGRP,NPLIN,HCPC))
+10 if HCPC=""
SET NPLIN=$ORDER(^TMP($JOB,TNAM,STATION,NPGRP,NPLIN))
+11 if NPLIN=""
SET NPGRP=$ORDER(^TMP($JOB,TNAM,STATION,NPGRP))
+12 if NPGRP=""
SET STATION=$ORDER(^TMP($JOB,TNAM,STATION))
+13 IF STATION=""!(STATION="Z")
SET RMPREOF=1
SET RMPRCHNG("HCPC_CODE")=0
SET RMPRCHNG("HCPC_ITEM")=0
SET RMPRCHNG("INVENTORY_IEN")=0
GOTO NXHCPCX
+14 if NPGRP=""
SET NPGRP=$ORDER(^TMP($JOB,TNAM,STATION,""))
SET RMPRCHNG("STATION")=1
+15 if NPLIN=""
SET NPLIN=$ORDER(^TMP($JOB,TNAM,STATION,NPGRP,""))
SET RMPRCHNG("NPPD_GROUP")=1
+16 if HCPC=""
SET HCPC=$ORDER(^TMP($JOB,TNAM,STATION,NPGRP,NPLIN,""))
SET RMPRCHNG("NPPD_LINE")=1
+17 SET RMPRCHNG("HCPC_CODE")=1
+18 SET ITEM=$ORDER(^TMP($JOB,TNAM,STATION,NPGRP,NPLIN,HCPC,""))
+19 SET RMPRCHNG("HCPC_ITEM")=1
+20 SET INVIEN=$ORDER(^TMP($JOB,TNAM,STATION,NPGRP,NPLIN,HCPC,ITEM,""))
+21 SET RMPRCHNG("INVENTORY_IEN")=1
+22 SET RMPRKEY("STATION")=STATION
+23 SET RMPRKEY("NPPD_GROUP")=NPGRP
+24 SET RMPRKEY("NPPD_LINE")=NPLIN
+25 SET RMPRKEY("HCPC")=HCPC
+26 SET RMPRKEY("HCPC_CODE")=$PIECE(HCPC,"/",1)
+27 SET RMPRKEY("HCPC_IEN")=$PIECE(HCPC,"/",2)
+28 SET RMPRKEY("HCPC_ITEM")=ITEM
+29 SET RMPRKEY("INVENTORY_IEN")=INVIEN
NXHCPCX QUIT
MAP(CALC,RUP) ;
+1 SET $PIECE(RUP,"^",8)=$PIECE(CALC,"^",2)
+2 SET $PIECE(RUP,"^",9)=$PIECE(CALC,"^",5)
+3 if +$PIECE(RUP,"^",8)
SET $PIECE(RUP,"^",10)=$JUSTIFY($PIECE(RUP,"^",9)/$PIECE(RUP,"^",8),0,2)
+4 SET $PIECE(RUP,"^",11)=$PIECE(CALC,"^",6)
+5 SET $PIECE(RUP,"^",12)=$PIECE(CALC,"^",7)
+6 SET $PIECE(RUP,"^",13)=$PIECE(CALC,"^",9)
+7 SET $PIECE(RUP,"^",14)=$PIECE(CALC,"^",11)
+8 if +$PIECE(RUP,"^",13)
SET $PIECE(RUP,"^",15)=$JUSTIFY($PIECE(RUP,"^",14)/$PIECE(RUP,"^",13),0,2)
+9 SET $PIECE(RUP,"^",16)=$PIECE(CALC,"^",1)
+10 SET $PIECE(RUP,"^",17)=$PIECE(CALC,"^",4)
+11 if +$PIECE(RUP,"^",16)
SET $PIECE(RUP,"^",18)=$JUSTIFY($PIECE(RUP,"^",17)/$PIECE(RUP,"^",16),0,2)
+12 SET $PIECE(RUP,"^",19)=$PIECE(CALC,"^",12)
+13 SET $PIECE(RUP,"^",20)=$PIECE(CALC,"^",13)
+14 SET $PIECE(RUP,"^",21)=$PIECE(CALC,"^",8)
+15 SET $PIECE(RUP,"^",22)=$PIECE(CALC,"^",10)
+16 if +$PIECE(RUP,"^",21)
SET $PIECE(RUP,"^",23)=$JUSTIFY($PIECE(RUP,"^",22)/$PIECE(RUP,"^",21),0,2)
+17 SET $PIECE(RUP,"^",24)=$GET(RMCALDAY)
+18 QUIT
