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