- 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 Feb 18, 2025@23:59:31 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
