GMPLBLDF ; SLC/MKB -- Build Problem Selection List from IB Enc Form ;5/12/94 10:26
;;2.0;Problem List;;Aug 25, 1994
EN ; Start here.
S X="IBDF18" X ^%ZOSF("TEST") I '$T D Q
. W !!,">>> The IB Encounter Form utility is not available.",!
EN0 S GMPLFORM=$$GETFORM^IBDF18 G:'GMPLFORM EXIT
W !,"Searching for the problems ..."
S X=$$COPYFORM^IBDF18(+GMPLFORM,"GMPL"),GMPL(0)=X
I 'X W !!,"No problems found. Please select another form.",! G EN0
EN1 ; Create list to copy problems into
S DIR(0)="FA^3:30",DIR("A")="LIST NAME: "
S:'$D(^GMPL(125,"B",$P(GMPLFORM,U,2))) DIR("B")=$P(GMPLFORM,U,2)
S DIR("?",1)="Enter the name you wish to give this list; use meaningful"
S DIR("?")="text, as it will be used as a title when presenting this list."
W !!,">>> Please create a new selection list in which to store these problems:"
EN2 D ^DIR G:$D(DUOUT)!($D(DTOUT)) EXIT
I $D(^GMPL(125,"B",Y)) W $C(7),!,"There is already a list by this name!",! G EN2
S DIC="^GMPL(125,",DIC(0)="L",DIC("DR")=".02////"_DT,DLAYGO=125 K DD,DO
D FILE^DICN I Y'>0 W !!,"ERROR -- Cannot create new list!",$C(7) G EXIT
S GMPLSLST=$P(Y,U,1,2),DIE=DIC,DA=+Y,DR=".03 CLINIC" D ^DIE ; clinic
EN3 ; Here we go ...
W !!,"Copying problems from "_$P(GMPLFORM,U,2)_" form into "
W:(42+$L($P(GMPLFORM,U,2))+$L($P(GMPLSLST,U,2))>80) !
W $P(GMPLSLST,U,2)_" list ..."
S (GSEQ,PSEQ,GMPLI)=0,GHDR="" S:'+GMPL(1) GHDR=$P(GMPL(1),U,2),GMPLI=1
S GSEQ=GSEQ+1,GMPLGRP=$$NEWGRP(GMPLFORM,GHDR,GSEQ)
F S GMPLI=$O(GMPL(GMPLI)) Q:GMPLI'>0 D
. S ITEM=$G(GMPL(GMPLI)) Q:'$L(ITEM)
. I '+ITEM D Q
. . S GSEQ=GSEQ+1,PSEQ=0,GMPLGRP=$$NEWGRP(GMPLFORM,$P(ITEM,U,2),GSEQ)
. S PSEQ=PSEQ+1,DIK="^GMPL(125.12,",ITEM=PSEQ_U_ITEM
. D NEW^GMPLBLD2(DIK,+GMPLGRP,ITEM) W "."
W " <done>"
EXIT ; Clean-up
K GMPL,GMPLSLST,GMPLGRP,GMPLI,GMPLFORM,GHDR,GSEQ,PSEQ,DIC,DIR,DIK,DR,X,Y,DIE,DA,DLAYGO
Q
;
NEWGRP(FORM,HDR,SEQ) ; Create new group entries in #125.1 and #125.11
N DIC,DD,DO,X,Y,DIK,ITEM,DLAYGO
S DIC="^GMPL(125.11,",DIC(0)="L",DIC("DR")="1////"_DT,DLAYGO=125.11
I $L(HDR),'$D(^GMPL(125.11,"B",$$UP^XLFSTR(HDR))) S X=$$UP^XLFSTR(HDR)
E S X=$E($P(FORM,U,2),1,23-$L(SEQ))_" GROUP "_SEQ
D FILE^DICN G:Y'>0 NGQ
S DIK="^GMPL(125.1,",ITEM=SEQ_U_+Y_U_HDR_"^1"
D NEW^GMPLBLD2(DIK,+GMPLSLST,ITEM)
NGQ S Y=$P(Y,U,1,2)
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLBLDF 2328 printed Oct 16, 2024@18:30:30 Page 2
GMPLBLDF ; SLC/MKB -- Build Problem Selection List from IB Enc Form ;5/12/94 10:26
+1 ;;2.0;Problem List;;Aug 25, 1994
EN ; Start here.
+1 SET X="IBDF18"
XECUTE ^%ZOSF("TEST")
IF '$TEST
Begin DoDot:1
+2 WRITE !!,">>> The IB Encounter Form utility is not available.",!
End DoDot:1
QUIT
EN0 SET GMPLFORM=$$GETFORM^IBDF18
if 'GMPLFORM
GOTO EXIT
+1 WRITE !,"Searching for the problems ..."
+2 SET X=$$COPYFORM^IBDF18(+GMPLFORM,"GMPL")
SET GMPL(0)=X
+3 IF 'X
WRITE !!,"No problems found. Please select another form.",!
GOTO EN0
EN1 ; Create list to copy problems into
+1 SET DIR(0)="FA^3:30"
SET DIR("A")="LIST NAME: "
+2 if '$DATA(^GMPL(125,"B",$PIECE(GMPLFORM,U,2)))
SET DIR("B")=$PIECE(GMPLFORM,U,2)
+3 SET DIR("?",1)="Enter the name you wish to give this list; use meaningful"
+4 SET DIR("?")="text, as it will be used as a title when presenting this list."
+5 WRITE !!,">>> Please create a new selection list in which to store these problems:"
EN2 DO ^DIR
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO EXIT
+1 IF $DATA(^GMPL(125,"B",Y))
WRITE $CHAR(7),!,"There is already a list by this name!",!
GOTO EN2
+2 SET DIC="^GMPL(125,"
SET DIC(0)="L"
SET DIC("DR")=".02////"_DT
SET DLAYGO=125
KILL DD,DO
+3 DO FILE^DICN
IF Y'>0
WRITE !!,"ERROR -- Cannot create new list!",$CHAR(7)
GOTO EXIT
+4 ; clinic
SET GMPLSLST=$PIECE(Y,U,1,2)
SET DIE=DIC
SET DA=+Y
SET DR=".03 CLINIC"
DO ^DIE
EN3 ; Here we go ...
+1 WRITE !!,"Copying problems from "_$PIECE(GMPLFORM,U,2)_" form into "
+2 if (42+$LENGTH($PIECE(GMPLFORM,U,2))+$LENGTH($PIECE(GMPLSLST,U,2))>80)
WRITE !
+3 WRITE $PIECE(GMPLSLST,U,2)_" list ..."
+4 SET (GSEQ,PSEQ,GMPLI)=0
SET GHDR=""
if '+GMPL(1)
SET GHDR=$PIECE(GMPL(1),U,2)
SET GMPLI=1
+5 SET GSEQ=GSEQ+1
SET GMPLGRP=$$NEWGRP(GMPLFORM,GHDR,GSEQ)
+6 FOR
SET GMPLI=$ORDER(GMPL(GMPLI))
if GMPLI'>0
QUIT
Begin DoDot:1
+7 SET ITEM=$GET(GMPL(GMPLI))
if '$LENGTH(ITEM)
QUIT
+8 IF '+ITEM
Begin DoDot:2
+9 SET GSEQ=GSEQ+1
SET PSEQ=0
SET GMPLGRP=$$NEWGRP(GMPLFORM,$PIECE(ITEM,U,2),GSEQ)
End DoDot:2
QUIT
+10 SET PSEQ=PSEQ+1
SET DIK="^GMPL(125.12,"
SET ITEM=PSEQ_U_ITEM
+11 DO NEW^GMPLBLD2(DIK,+GMPLGRP,ITEM)
WRITE "."
End DoDot:1
+12 WRITE " <done>"
EXIT ; Clean-up
+1 KILL GMPL,GMPLSLST,GMPLGRP,GMPLI,GMPLFORM,GHDR,GSEQ,PSEQ,DIC,DIR,DIK,DR,X,Y,DIE,DA,DLAYGO
+2 QUIT
+3 ;
NEWGRP(FORM,HDR,SEQ) ; Create new group entries in #125.1 and #125.11
+1 NEW DIC,DD,DO,X,Y,DIK,ITEM,DLAYGO
+2 SET DIC="^GMPL(125.11,"
SET DIC(0)="L"
SET DIC("DR")="1////"_DT
SET DLAYGO=125.11
+3 IF $LENGTH(HDR)
IF '$DATA(^GMPL(125.11,"B",$$UP^XLFSTR(HDR)))
SET X=$$UP^XLFSTR(HDR)
+4 IF '$TEST
SET X=$EXTRACT($PIECE(FORM,U,2),1,23-$LENGTH(SEQ))_" GROUP "_SEQ
+5 DO FILE^DICN
if Y'>0
GOTO NGQ
+6 SET DIK="^GMPL(125.1,"
SET ITEM=SEQ_U_+Y_U_HDR_"^1"
+7 DO NEW^GMPLBLD2(DIK,+GMPLSLST,ITEM)
NGQ SET Y=$PIECE(Y,U,1,2)
+1 QUIT Y
