AQAQEDTS.m

AQAQEDTS ;IHS/ANMC/LJF - CREDENTIALING SUBRTNS; [ 09/15/95  8:48 AM ]

 ;;2.2;STAFF CREDENTIALS;**7**;01 OCT 1992

 ;

ITEMFIND ;EP;>>subrtn to find each items on page and display them by number<<

 ;

 ;***> find items for this page

 K AQAQA

 F  S AQAQTM=$O(^AQAQX(AQAQPT,"PG",AQAQPN,"IT","B",AQAQTM)) Q:AQAQTM'=+AQAQTM  D

 .S AQAQTMN=0

 .F  S AQAQTMN=$O(^AQAQX(AQAQPT,"PG",AQAQPN,"IT","B",AQAQTM,AQAQTMN)) Q:AQAQTMN=""  D

 ..Q:'$D(^AQAQX(AQAQPT,"PG",AQAQPN,"IT",AQAQTMN,0))

 ..;

 ..;***> print items in order with contents and save field # in array

 ..S AQAQMFL=^(0),AQAQFLD=$P(AQAQMFL,U,2),AQAQSEN=$P(AQAQMFL,U,5)

 ..S AQAQSFL=$P(AQAQMFL,U,3),AQAQDR=$P(AQAQMFL,U,4)

 ..W !,$J(+AQAQMFL,2),")  ",$P(^DD(9002165,AQAQFLD,0),U)

 ..I AQAQSFL]"" D FSTMULT Q

 ..K ^UTILITY("DIQ1",$J)

 ..S (DIC,AQAQFL)=9002165,DA=AQAQPRV,DR=AQAQFLD D EN^DIQ1

 ..I $D(^UTILITY("DIQ1",$J,AQAQFL,DA,AQAQFLD)) W ?45,^(AQAQFLD)

 ..K ^UTILITY("DIQ1",$J)

 ..S AQAQA(+AQAQMFL)=AQAQFLD

 ;

 ;***> choose items to edit and edit via ^die

 S (AQAQTM,AQAQX)=0 W !!

 F  S AQAQX=$O(AQAQA(AQAQX)) Q:AQAQX=""  S AQAQTM=AQAQX

 S DIR(0)="LO^0:"_AQAQTM D ^DIR Q:$D(DIRUT)  Q:Y=-1  S DR=""

 S AQAQXLF(".")=",",Y=$$REPLACE^XLFSTR(Y,.AQAQXLF) K AQAQXLF ;PATCH #7

 I +Y=0 F  S X=$O(AQAQA(X)) Q:X=""  D

 .I AQAQA(X)[U S DR(2,$P(AQAQA(X),U,2))=$P(AQAQA(X),U,3)

 .S DR=DR_";"_$P(AQAQA(X),U)

 E  F  S X=$P(Y,",") Q:X=""  D

 .I AQAQA(X)[U S DR(2,$P(AQAQA(X),U,3))=$P(AQAQA(X),U,2)

 .S X=$P(AQAQA(X),U),DR=DR_";"_X

 .S Y=$P(Y,",",2,99)

 I DR?1";".E S DR=$E(DR,2,99)

 K DIE S DIE=9002165,DA=AQAQPRV D ^DIE

 K DIR S DIR(0)="Y",DIR("B")="NO" ;PATCH #7

 S DIR("A")="Do you wish to REVIEW this category" D ^DIR K DIR

 I Y=1 S AQAQTM=0,DIR("A")=AQAQDIR K AQAQDIR W !!! G ITEMFIND

 Q

 ;>>end of ITEMFIND subrtn<<

 ;

 ;

FSTMULT ;>>subrtn called by ITEMFIND for ist entry in multiple field

 ;

 S AQAQNOD=$P($P(^DD(9002165,AQAQFLD,0),U,4),";"),(AQAQTMP,AQAQSEN)=0

 F  S AQAQTMP=$O(^AQAQC(AQAQPRV,AQAQNOD,AQAQTMP)) Q:AQAQTMP'=+AQAQTMP  D

 .S AQAQSEN=AQAQTMP

 S Y=$P($G(^AQAQC(AQAQPRV,AQAQNOD,AQAQSEN,0)),U)

 I Y]"" S C=$P(^DD(AQAQSFL,+AQAQDR,0),U,2) D Y^DIQ W ?45,Y

 S AQAQA(AQAQTM)=AQAQFLD_U_AQAQDR_U_AQAQSFL

 Q

 ;>>end of FSTMULT subrtn<<

 ;

 ;

MULTFIND ;EP;>>subrtn to display multiple fields' data<<

 ;

 ;***> set variables about subfile

 S AQAQFLD=$P(AQAQSTR,U),AQAQSFD=$P(AQAQSTR,U,2),AQAQPC=$P(AQAQSTR,U,3)

 S AQAQSTR1=^DD(9002165,AQAQFLD,0),AQAQSF=$P(AQAQSTR1,U,2)

 S AQAQSUB=$P($P(AQAQSTR1,U,4),";"),AQAQNOD=$P($P(AQAQSTR1,U,4),";",2)

 ;

 ;***> loop thru entries under multiple and display them by #

 S (AQAQX,AQAQCNT)=0,DA(1)=AQAQPRV

 F  S AQAQX=$O(^AQAQC(AQAQPRV,AQAQSUB,AQAQX)) Q:AQAQX'=+AQAQX  D

 .S AQAQTM=$P(^AQAQC(AQAQPRV,AQAQSUB,AQAQX,AQAQNOD),U,AQAQPC)

 .S AQAQCNT=AQAQCNT+1,AQAQA(AQAQCNT)=AQAQX

 .S Y=AQAQTM,C=$P(^DD(+AQAQSF,+AQAQSFD,0),U,2) D Y^DIQ

 .W !,AQAQCNT,")  ",Y

 .Q

 ;***> last number is choice to add new entry

 I AQAQCNT>0 S AQAQCNT=AQAQCNT+1 W !,AQAQCNT,")  ADD NEW ENTRY"

 I AQAQCNT=0 G ADD ;add if no entries in file

 W !

 ;

CHOOSE ;***> choose item(s) to edit

 S DIR(0)="NO^1:"_AQAQCNT

 D ^DIR Q:X=""  Q:$D(DIRUT)  G CHOOSE:Y=-1

 I +Y=AQAQCNT G ADD G MULTFIND

 E  S DA=AQAQA(+Y) G EDIT G MULTFIND

 ;

ADD ;add new entry to subfile

 I '$D(^AQAQC(AQAQPRV,AQAQSUB,0)) S ^(0)=U_AQAQSF

 K DIC S DIC="^AQAQC("_AQAQPRV_","""_AQAQSUB_""",",DIC(0)="AQEMLZI"

 D ^DIC S DA=+Y Q:Y=-1

 ;

EDIT ;***> edit entries

 K DIC,DIE S DIE="^AQAQC("_AQAQPRV_","""_AQAQSUB_""","

 S DR=AQAQSFD D ^DIE

 W !!!! G MULTFIND

 ;

 ;>>end of MULTFIND subrtn<<

AQAQEDTS  ;IHS/ANMC/LJF - CREDENTIALING SUBRTNS; [ 09/15/95  8:48 AM ]

 +1       ;;2.2;STAFF CREDENTIALS;**7**;01 OCT 1992

 +2       ;

ITEMFIND  ;EP;>>subrtn to find each items on page and display them by number<<

 +1       ;

 +2       ;***> find items for this page

 +3        KILL AQAQA

 +4        FOR 

               SET AQAQTM=$ORDER(^AQAQX(AQAQPT,"PG",AQAQPN,"IT","B",AQAQTM))

               IF AQAQTM'=+AQAQTM

                   QUIT 

               Begin DoDot:1

 +5                SET AQAQTMN=0

 +6                FOR 

                       SET AQAQTMN=$ORDER(^AQAQX(AQAQPT,"PG",AQAQPN,"IT","B",AQAQTM,AQAQTMN))

                       IF AQAQTMN=""

                           QUIT 

                       Begin DoDot:2

 +7                        IF '$DATA(^AQAQX(AQAQPT,"PG",AQAQPN,"IT",AQAQTMN,0))

                               QUIT 

 +8       ;

 +9       ;***> print items in order with contents and save field # in array

 +10                       SET AQAQMFL=^(0)

                           SET AQAQFLD=$PIECE(AQAQMFL,U,2)

                           SET AQAQSEN=$PIECE(AQAQMFL,U,5)

 +11                       SET AQAQSFL=$PIECE(AQAQMFL,U,3)

                           SET AQAQDR=$PIECE(AQAQMFL,U,4)

 +12                       WRITE !,$JUSTIFY(+AQAQMFL,2),")  ",$PIECE(^DD(9002165,AQAQFLD,0),U)

 +13                       IF AQAQSFL]""

                               DO FSTMULT

                               QUIT 

 +14                       KILL ^UTILITY("DIQ1",$JOB)

 +15                       SET (DIC,AQAQFL)=9002165

                           SET DA=AQAQPRV

                           SET DR=AQAQFLD

                           DO EN^DIQ1

 +16                       IF $DATA(^UTILITY("DIQ1",$JOB,AQAQFL,DA,AQAQFLD))

                               WRITE ?45,^(AQAQFLD)

 +17                       KILL ^UTILITY("DIQ1",$JOB)

 +18                       SET AQAQA(+AQAQMFL)=AQAQFLD

                       End DoDot:2

               End DoDot:1

 +19      ;

 +20      ;***> choose items to edit and edit via ^die

 +21       SET (AQAQTM,AQAQX)=0

           WRITE !!

 +22       FOR 

               SET AQAQX=$ORDER(AQAQA(AQAQX))

               IF AQAQX=""

                   QUIT 

               SET AQAQTM=AQAQX

 +23       SET DIR(0)="LO^0:"_AQAQTM

           DO ^DIR

           IF $DATA(DIRUT)

               QUIT 

           IF Y=-1

               QUIT 

           SET DR=""

 +24      ;PATCH #7

           SET AQAQXLF(".")=","

           SET Y=$$REPLACE^XLFSTR(Y,.AQAQXLF)

           KILL AQAQXLF

 +25       IF +Y=0

               FOR 

                   SET X=$ORDER(AQAQA(X))

                   IF X=""

                       QUIT 

                   Begin DoDot:1

 +26                   IF AQAQA(X)[U

                           SET DR(2,$PIECE(AQAQA(X),U,2))=$PIECE(AQAQA(X),U,3)

 +27                   SET DR=DR_";"_$PIECE(AQAQA(X),U)

                   End DoDot:1

 +28      IF '$TEST

               FOR 

                   SET X=$PIECE(Y,",")

                   IF X=""

                       QUIT 

                   Begin DoDot:1

 +29                   IF AQAQA(X)[U

                           SET DR(2,$PIECE(AQAQA(X),U,3))=$PIECE(AQAQA(X),U,2)

 +30                   SET X=$PIECE(AQAQA(X),U)

                       SET DR=DR_";"_X

 +31                   SET Y=$PIECE(Y,",",2,99)

                   End DoDot:1

 +32       IF DR?1";".E

               SET DR=$EXTRACT(DR,2,99)

 +33       KILL DIE

           SET DIE=9002165

           SET DA=AQAQPRV

           DO ^DIE

 +34      ;PATCH #7

           KILL DIR

           SET DIR(0)="Y"

           SET DIR("B")="NO"

 +35       SET DIR("A")="Do you wish to REVIEW this category"

           DO ^DIR

           KILL DIR

 +36       IF Y=1

               SET AQAQTM=0

               SET DIR("A")=AQAQDIR

               KILL AQAQDIR

               WRITE !!!

               GOTO ITEMFIND

 +37       QUIT 

 +38      ;>>end of ITEMFIND subrtn<<

 +39      ;

 +40      ;

FSTMULT   ;>>subrtn called by ITEMFIND for ist entry in multiple field

 +1       ;

 +2        SET AQAQNOD=$PIECE($PIECE(^DD(9002165,AQAQFLD,0),U,4),";")

           SET (AQAQTMP,AQAQSEN)=0

 +3        FOR 

               SET AQAQTMP=$ORDER(^AQAQC(AQAQPRV,AQAQNOD,AQAQTMP))

               IF AQAQTMP'=+AQAQTMP

                   QUIT 

               Begin DoDot:1

 +4                SET AQAQSEN=AQAQTMP

               End DoDot:1

 +5        SET Y=$PIECE($GET(^AQAQC(AQAQPRV,AQAQNOD,AQAQSEN,0)),U)

 +6        IF Y]""

               SET C=$PIECE(^DD(AQAQSFL,+AQAQDR,0),U,2)

               DO Y^DIQ

               WRITE ?45,Y

 +7        SET AQAQA(AQAQTM)=AQAQFLD_U_AQAQDR_U_AQAQSFL

 +8        QUIT 

 +9       ;>>end of FSTMULT subrtn<<

 +10      ;

 +11      ;

MULTFIND  ;EP;>>subrtn to display multiple fields' data<<

 +1       ;

 +2       ;***> set variables about subfile

 +3        SET AQAQFLD=$PIECE(AQAQSTR,U)

           SET AQAQSFD=$PIECE(AQAQSTR,U,2)

           SET AQAQPC=$PIECE(AQAQSTR,U,3)

 +4        SET AQAQSTR1=^DD(9002165,AQAQFLD,0)

           SET AQAQSF=$PIECE(AQAQSTR1,U,2)

 +5        SET AQAQSUB=$PIECE($PIECE(AQAQSTR1,U,4),";")

           SET AQAQNOD=$PIECE($PIECE(AQAQSTR1,U,4),";",2)

 +6       ;

 +7       ;***> loop thru entries under multiple and display them by #

 +8        SET (AQAQX,AQAQCNT)=0

           SET DA(1)=AQAQPRV

 +9        FOR 

               SET AQAQX=$ORDER(^AQAQC(AQAQPRV,AQAQSUB,AQAQX))

               IF AQAQX'=+AQAQX

                   QUIT 

               Begin DoDot:1

 +10               SET AQAQTM=$PIECE(^AQAQC(AQAQPRV,AQAQSUB,AQAQX,AQAQNOD),U,AQAQPC)

 +11               SET AQAQCNT=AQAQCNT+1

                   SET AQAQA(AQAQCNT)=AQAQX

 +12               SET Y=AQAQTM

                   SET C=$PIECE(^DD(+AQAQSF,+AQAQSFD,0),U,2)

                   DO Y^DIQ

 +13               WRITE !,AQAQCNT,")  ",Y

 +14               QUIT 

               End DoDot:1

 +15      ;***> last number is choice to add new entry

 +16       IF AQAQCNT>0

               SET AQAQCNT=AQAQCNT+1

               WRITE !,AQAQCNT,")  ADD NEW ENTRY"

 +17      ;add if no entries in file

           IF AQAQCNT=0

               GOTO ADD

 +18       WRITE !

 +19      ;

CHOOSE    ;***> choose item(s) to edit

 +1        SET DIR(0)="NO^1:"_AQAQCNT

 +2        DO ^DIR

           IF X=""

               QUIT 

           IF $DATA(DIRUT)

               QUIT 

           IF Y=-1

               GOTO CHOOSE

 +3        IF +Y=AQAQCNT

               GOTO ADD

               GOTO MULTFIND

 +4       IF '$TEST

               SET DA=AQAQA(+Y)

               GOTO EDIT

               GOTO MULTFIND

 +5       ;

ADD       ;add new entry to subfile

 +1        IF '$DATA(^AQAQC(AQAQPRV,AQAQSUB,0))

               SET ^(0)=U_AQAQSF

 +2        KILL DIC

           SET DIC="^AQAQC("_AQAQPRV_","""_AQAQSUB_""","

           SET DIC(0)="AQEMLZI"

 +3        DO ^DIC

           SET DA=+Y

           IF Y=-1

               QUIT 

 +4       ;

EDIT      ;***> edit entries

 +1        KILL DIC,DIE

           SET DIE="^AQAQC("_AQAQPRV_","""_AQAQSUB_""","

 +2        SET DR=AQAQSFD

           DO ^DIE

 +3        WRITE !!!!

           GOTO MULTFIND

 +4       ;

 +5       ;>>end of MULTFIND subrtn<<