IBDY315P ;ALB/AAS - Post Install routine for ibd*3*15 - 11-Oct-97
;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
;
D CLEANUP,AUTOINS,DEL,TRANS
Q
;
AUTOINS ; -- auto install tool kit blocks into production
N FORM,NEWFORM,FORMNM,CNT,CNT1,ARY,NAME,X,Y,NEWBLOCK,A,EXCLUDE,BLK,CNTF,CNTB
D MES^XPDUTL(">>> Now Attempting to automatically add Clinical Reminders Tool Kit Blocks.")
S (CNTB,CNTF)=0
;
; -- add all tool kit blocks
S FORMNM="TOOL KIT"
I '$O(^IBE(357,"B",FORMNM,0)) Q
S ORD="" F S ORD=$O(^IBE(358.1,"D",ORD)) Q:ORD="" S BLK=0 F S BLK=$O(^IBE(358.1,"D",ORD,BLK)) Q:'BLK D
.S NAME=$P($G(^IBE(358.1,+BLK,0)),"^")
.Q:$P($G(^IBE(358.1,BLK,0)),"^",14)'=1 ;not toolkit
.I $O(^IBE(357.1,"B",NAME,0)) D MES^XPDUTL(" Block "_NAME_" already exists") Q
.D MES^XPDUTL(" Moving Block '"_$P($G(^IBE(358.1,+BLK,0)),"^")_"' from import/export to Tool Kit")
.N IBTKBLK S IBTKBLK=1
.S NEWBLOCK=$$COPYBLK^IBDFU2(BLK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13),CNTB=CNTB+1
.D:$G(NEWBLOCK) DLTBLK^IBDFU3(BLK,"",358.1)
;
; -- clear workspace
D DLTALL^IBDE2
Q
;
DEL ; -- delete unused field in 357.6
S DIK="^DD(357.613,",DA=1,DA(1)=357.613
D ^DIK
K DIK,DA
Q
;
CLEANUP ; -- Clean up initial reminder blocks
N IBDI,IBDJ
S IBDI=0
F S IBDI=$O(^IBE(357.2,"B","CLINICAL REMINDERS",IBDI)) Q:'IBDI D
.S IBDJ=0
.F S IBDJ=$O(^IBE(357.2,IBDI,2,IBDJ)) Q:'IBDJ D
..I $P($G(^IBE(357.2,IBDI,2,IBDJ,0)),"^",3)=13 S $P(^IBE(357.2,IBDI,2,IBDJ,0),"^",3)=12
..I $P($G(^IBE(357.2,IBDI,2,IBDJ,0)),"^",3)=17 S $P(^IBE(357.2,IBDI,2,IBDJ,0),"^",3)=18
;
S IBDI=0
F S IBDI=$O(^IBE(357.2,"B","FULL CLINICAL REMINDER",IBDI)) Q:'IBDI D
.S IBDJ=0
.F S IBDJ=$O(^IBE(357.2,IBDI,2,IBDJ)) Q:'IBDJ D
..I $P($G(^IBE(357.2,IBDI,2,IBDJ,0)),"^",3)=13 S $P(^IBE(357.2,IBDI,2,IBDJ,0),"^",3)=12
..I $P($G(^IBE(357.2,IBDI,2,IBDJ,0)),"^",3)=17 S $P(^IBE(357.2,IBDI,2,IBDJ,0),"^",3)=18
Q
BLOCKS ;;
;;TOOL KIT
;;
Q
TRANS D MES^XPDUTL(">>> Translating letters O and l to numbers 0 and 1 in Time Queued field of file 357.09.")
N IBX,IBX1,IBY1,IBNODE
S IBX1=0
F S IBX1=$O(^IBD(357.09,IBX1)) Q:'IBX1 D
.S IBY1=0 F S IBY1=$O(^IBD(357.09,IBX1,"Q",IBY1)) Q:'IBY1 D
..S IBNODE=$G(^IBD(357.09,IBX1,"Q",IBY1,0))
..S IBX=$P(IBNODE,"^",13)
..I IBX]"" S IBX=$TR(IBX,"OoLl","0011"),$P(^IBD(357.09,IBX1,"Q",IBY1,0),"^",13)=IBX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDY315P 2409 printed Nov 22, 2024@18:05:25 Page 2
IBDY315P ;ALB/AAS - Post Install routine for ibd*3*15 - 11-Oct-97
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
+2 ;
+3 DO CLEANUP
DO AUTOINS
DO DEL
DO TRANS
+4 QUIT
+5 ;
AUTOINS ; -- auto install tool kit blocks into production
+1 NEW FORM,NEWFORM,FORMNM,CNT,CNT1,ARY,NAME,X,Y,NEWBLOCK,A,EXCLUDE,BLK,CNTF,CNTB
+2 DO MES^XPDUTL(">>> Now Attempting to automatically add Clinical Reminders Tool Kit Blocks.")
+3 SET (CNTB,CNTF)=0
+4 ;
+5 ; -- add all tool kit blocks
+6 SET FORMNM="TOOL KIT"
+7 IF '$ORDER(^IBE(357,"B",FORMNM,0))
QUIT
+8 SET ORD=""
FOR
SET ORD=$ORDER(^IBE(358.1,"D",ORD))
if ORD=""
QUIT
SET BLK=0
FOR
SET BLK=$ORDER(^IBE(358.1,"D",ORD,BLK))
if 'BLK
QUIT
Begin DoDot:1
+9 SET NAME=$PIECE($GET(^IBE(358.1,+BLK,0)),"^")
+10 ;not toolkit
if $PIECE($GET(^IBE(358.1,BLK,0)),"^",14)'=1
QUIT
+11 IF $ORDER(^IBE(357.1,"B",NAME,0))
DO MES^XPDUTL(" Block "_NAME_" already exists")
QUIT
+12 DO MES^XPDUTL(" Moving Block '"_$PIECE($GET(^IBE(358.1,+BLK,0)),"^")_"' from import/export to Tool Kit")
+13 NEW IBTKBLK
SET IBTKBLK=1
+14 SET NEWBLOCK=$$COPYBLK^IBDFU2(BLK,$$TKFORM^IBDFU2C,358.1,357.1,"","",$$TKORDER^IBDF13)
SET CNTB=CNTB+1
+15 if $GET(NEWBLOCK)
DO DLTBLK^IBDFU3(BLK,"",358.1)
End DoDot:1
+16 ;
+17 ; -- clear workspace
+18 DO DLTALL^IBDE2
+19 QUIT
+20 ;
DEL ; -- delete unused field in 357.6
+1 SET DIK="^DD(357.613,"
SET DA=1
SET DA(1)=357.613
+2 DO ^DIK
+3 KILL DIK,DA
+4 QUIT
+5 ;
CLEANUP ; -- Clean up initial reminder blocks
+1 NEW IBDI,IBDJ
+2 SET IBDI=0
+3 FOR
SET IBDI=$ORDER(^IBE(357.2,"B","CLINICAL REMINDERS",IBDI))
if 'IBDI
QUIT
Begin DoDot:1
+4 SET IBDJ=0
+5 FOR
SET IBDJ=$ORDER(^IBE(357.2,IBDI,2,IBDJ))
if 'IBDJ
QUIT
Begin DoDot:2
+6 IF $PIECE($GET(^IBE(357.2,IBDI,2,IBDJ,0)),"^",3)=13
SET $PIECE(^IBE(357.2,IBDI,2,IBDJ,0),"^",3)=12
+7 IF $PIECE($GET(^IBE(357.2,IBDI,2,IBDJ,0)),"^",3)=17
SET $PIECE(^IBE(357.2,IBDI,2,IBDJ,0),"^",3)=18
End DoDot:2
End DoDot:1
+8 ;
+9 SET IBDI=0
+10 FOR
SET IBDI=$ORDER(^IBE(357.2,"B","FULL CLINICAL REMINDER",IBDI))
if 'IBDI
QUIT
Begin DoDot:1
+11 SET IBDJ=0
+12 FOR
SET IBDJ=$ORDER(^IBE(357.2,IBDI,2,IBDJ))
if 'IBDJ
QUIT
Begin DoDot:2
+13 IF $PIECE($GET(^IBE(357.2,IBDI,2,IBDJ,0)),"^",3)=13
SET $PIECE(^IBE(357.2,IBDI,2,IBDJ,0),"^",3)=12
+14 IF $PIECE($GET(^IBE(357.2,IBDI,2,IBDJ,0)),"^",3)=17
SET $PIECE(^IBE(357.2,IBDI,2,IBDJ,0),"^",3)=18
End DoDot:2
End DoDot:1
+15 QUIT
BLOCKS ;;
+1 ;;TOOL KIT
+2 ;;
+3 QUIT
TRANS DO MES^XPDUTL(">>> Translating letters O and l to numbers 0 and 1 in Time Queued field of file 357.09.")
+1 NEW IBX,IBX1,IBY1,IBNODE
+2 SET IBX1=0
+3 FOR
SET IBX1=$ORDER(^IBD(357.09,IBX1))
if 'IBX1
QUIT
Begin DoDot:1
+4 SET IBY1=0
FOR
SET IBY1=$ORDER(^IBD(357.09,IBX1,"Q",IBY1))
if 'IBY1
QUIT
Begin DoDot:2
+5 SET IBNODE=$GET(^IBD(357.09,IBX1,"Q",IBY1,0))
+6 SET IBX=$PIECE(IBNODE,"^",13)
+7 IF IBX]""
SET IBX=$TRANSLATE(IBX,"OoLl","0011")
SET $PIECE(^IBD(357.09,IBX1,"Q",IBY1,0),"^",13)=IBX
End DoDot:2
End DoDot:1
+8 QUIT
