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<<
