- BPXRMEX1 ; IHS/MSC/MGH - Packing save routines. ;13-Aug-2015 12:06;du
- ;;2.0;CLINICAL REMINDERS;**1005**;Feb 04, 2005;Build 23
- ;==========================================
- SROC(FILENUM,ROCIEN,PACKLIST) ;Reminder Order Checks.
- ;packed order check structure up
- D SGENR^PXRMEXPS(FILENUM,ROCIEN,.PACKLIST)
- N GBL,SUB,DRCL,FNUM,OI,OLIST,PHAR,RIEN,ROUTINE,TIEN,TLIST,WPNODE
- ;Process the pharmacy multiple.
- S PHAR=""
- F S PHAR=$O(^PXD(801,ROCIEN,1.5,"B",PHAR)) Q:PHAR="" D
- . S IEN=$P(PHAR,";"),GBL=$P(PHAR,";",2)
- . S FNUM=$$GETFNUM^PXRMEXPS(GBL)
- . S ROUTINE=$$GETSRTN^PXRMEXPS(FNUM)_"(FNUM,IEN,.PACKLIST)"
- . D @ROUTINE
- ;packed list of Orderable Item
- I $D(^PXD(801,ROCIEN,2)) D
- .S SUB=0 F S SUB=$O(^PXD(801,ROCIEN,2,SUB)) Q:SUB'>0 D
- ..S OI=$P($G(^PXD(801,ROCIEN,2,SUB,0)),U) Q:OI'>0
- ..S ROUTINE=$$GETSRTN^PXRMEXPS(101.43)_"(101.43,OI,.PACKLIST)"
- ..D @ROUTINE
- ;loop through rules and packed definitions or terms
- S SUB=0 F S SUB=$O(^PXD(801,ROCIEN,3,SUB)) Q:SUB'>0 D
- .S RIEN=$P($G(^PXD(801,ROCIEN,3,SUB,0)),U) Q:RIEN'>0
- .S ROUTINE=$$GETSRTN^PXRMEXPS(801.1)_"(801.1,RIEN,.PACKLIST)"
- .D @ROUTINE
- Q
- SRULE(FILENUM,RULEIEN,PACKLIST) ;Reminder Order Check Rules.
- ;packed order check structure up
- D SGENR^PXRMEXPS(FILENUM,RULEIEN,.PACKLIST)
- N OLIST,RIEN,ROUTINE,TIEN,TLIST
- I $D(^PXD(801.1,RULEIEN,3,4))>0 D
- .;search for TIU Objects
- .D TIUSRCH^PXRMEXU1("^PXD(801.1,",RULEIEN,",4",.OLIST,.TLIST)
- .I $D(OLIST)>0 D
- ..S ROUTINE=$$GETSRTN^PXRMEXPS(8925.1)_"(8925.1,.OLIST,.PACKLIST)"
- ..D @ROUTINE K OLIST
- .K TLIST
- .;packed term up only
- S TIEN=$P($G(^PXD(801.1,RULEIEN,2)),U) I TIEN>0 D Q
- .S ROUTINE=$$GETSRTN^PXRMEXPS(811.5)_"(811.5,TIEN,.PACKLIST)"
- .D @ROUTINE
- ;packed definition up if defined
- S RIEN=$P($G(^PXD(801.1,RULEIEN,3)),U) I RIEN>0 D
- .S ROUTINE=$$GETSRTN^PXRMEXPS(811.9)_"(811.9,RIEN,.PACKLIST)"
- .D @ROUTINE
- Q
- ;
- BPXRMEX1 ; IHS/MSC/MGH - Packing save routines. ;13-Aug-2015 12:06;du
- +1 ;;2.0;CLINICAL REMINDERS;**1005**;Feb 04, 2005;Build 23
- +2 ;==========================================
- SROC(FILENUM,ROCIEN,PACKLIST) ;Reminder Order Checks.
- +1 ;packed order check structure up
- +2 DO SGENR^PXRMEXPS(FILENUM,ROCIEN,.PACKLIST)
- +3 NEW GBL,SUB,DRCL,FNUM,OI,OLIST,PHAR,RIEN,ROUTINE,TIEN,TLIST,WPNODE
- +4 ;Process the pharmacy multiple.
- +5 SET PHAR=""
- +6 FOR
- SET PHAR=$ORDER(^PXD(801,ROCIEN,1.5,"B",PHAR))
- IF PHAR=""
- QUIT
- Begin DoDot:1
- +7 SET IEN=$PIECE(PHAR,";")
- SET GBL=$PIECE(PHAR,";",2)
- +8 SET FNUM=$$GETFNUM^PXRMEXPS(GBL)
- +9 SET ROUTINE=$$GETSRTN^PXRMEXPS(FNUM)_"(FNUM,IEN,.PACKLIST)"
- +10 DO @ROUTINE
- End DoDot:1
- +11 ;packed list of Orderable Item
- +12 IF $DATA(^PXD(801,ROCIEN,2))
- Begin DoDot:1
- +13 SET SUB=0
- FOR
- SET SUB=$ORDER(^PXD(801,ROCIEN,2,SUB))
- IF SUB'>0
- QUIT
- Begin DoDot:2
- +14 SET OI=$PIECE($GET(^PXD(801,ROCIEN,2,SUB,0)),U)
- IF OI'>0
- QUIT
- +15 SET ROUTINE=$$GETSRTN^PXRMEXPS(101.43)_"(101.43,OI,.PACKLIST)"
- +16 DO @ROUTINE
- End DoDot:2
- End DoDot:1
- +17 ;loop through rules and packed definitions or terms
- +18 SET SUB=0
- FOR
- SET SUB=$ORDER(^PXD(801,ROCIEN,3,SUB))
- IF SUB'>0
- QUIT
- Begin DoDot:1
- +19 SET RIEN=$PIECE($GET(^PXD(801,ROCIEN,3,SUB,0)),U)
- IF RIEN'>0
- QUIT
- +20 SET ROUTINE=$$GETSRTN^PXRMEXPS(801.1)_"(801.1,RIEN,.PACKLIST)"
- +21 DO @ROUTINE
- End DoDot:1
- +22 QUIT
- SRULE(FILENUM,RULEIEN,PACKLIST) ;Reminder Order Check Rules.
- +1 ;packed order check structure up
- +2 DO SGENR^PXRMEXPS(FILENUM,RULEIEN,.PACKLIST)
- +3 NEW OLIST,RIEN,ROUTINE,TIEN,TLIST
- +4 IF $DATA(^PXD(801.1,RULEIEN,3,4))>0
- Begin DoDot:1
- +5 ;search for TIU Objects
- +6 DO TIUSRCH^PXRMEXU1("^PXD(801.1,",RULEIEN,",4",.OLIST,.TLIST)
- +7 IF $DATA(OLIST)>0
- Begin DoDot:2
- +8 SET ROUTINE=$$GETSRTN^PXRMEXPS(8925.1)_"(8925.1,.OLIST,.PACKLIST)"
- +9 DO @ROUTINE
- KILL OLIST
- End DoDot:2
- +10 KILL TLIST
- +11 ;packed term up only
- End DoDot:1
- +12 SET TIEN=$PIECE($GET(^PXD(801.1,RULEIEN,2)),U)
- IF TIEN>0
- Begin DoDot:1
- +13 SET ROUTINE=$$GETSRTN^PXRMEXPS(811.5)_"(811.5,TIEN,.PACKLIST)"
- +14 DO @ROUTINE
- End DoDot:1
- QUIT
- +15 ;packed definition up if defined
- +16 SET RIEN=$PIECE($GET(^PXD(801.1,RULEIEN,3)),U)
- IF RIEN>0
- Begin DoDot:1
- +17 SET ROUTINE=$$GETSRTN^PXRMEXPS(811.9)_"(811.9,RIEN,.PACKLIST)"
- +18 DO @ROUTINE
- End DoDot:1
- +19 QUIT
- +20 ;
