AQAQEDT ;IHS/ANMC/LJF - MAIN DRIVER FOR DATA ENTRY; [ 09/15/95 8:46 AM ]
;;2.2;STAFF CREDENTIALS;**7**;01 OCT 1992
;
;This routine uses the QI Data Entry file to create data entry
;screens and controls editing of those screens.
;The calling option sends AQAQOPTN (option name) before calling rtn
;5/2/94 Routine modified to work with changes to QI Data Entry file
;needed by QAI Mgt. System. Distributed in patch AQAO*1*1.
;
SETOPT K DIC S X=AQAQOPTN,DIC(0)="",DIC="^AQAQX("
D ^DIC G END:Y=-1 S AQAQPT=+Y
;
;***> for each provider, choose pages and data items to enter/edit
F D Q:$D(DIRUT) Q:Y=-1
.D GETPROV Q:X=U Q:X=""
.D PAGELOOP K DIRUT
;
END ;***> eoj
D KILL^AQAQUTIL Q
;
;>>>>END OF MAIN ROUTINE; SUBRTNS TO FOLLOW<<<<<
;
GETPROV ;>>subrtn ask for provider & find/create entry in Credentialing file<<
;***> ask provider name
K DIC S DIC("A")="Select PROVIDER NAME: ",DIC(0)="AELMQZ"
S (DIC,DLAYGO)=9002165 D ^DIC
Q:X=U Q:X="" G GETPROV:Y=-1 S AQAQPRV=+Y
S AQAQPRVN=$P(^DIC(16,AQAQPRV,0),U) ;provider name
S AQAQPRVC="",Y=$P($G(^DIC(6,AQAQPRV,0)),U,4)
I Y]"" S C=$P(^DD(6,2,0),U,2) D Y^DIQ S AQAQPRVC=Y ;provider class
Q
;
;
PAGELOOP ;>>subrtn to get each page (screen), display items and do edit<<
;***> find all pages available to work on
S AQAQPG=0,AQAQOPTT=$P(^AQAQX(AQAQPT,0),U,2)
W @IOF,!?80-$L(AQAQOPTT)/2,AQAQOPTT
W !?80-$L(AQAQPRVN)/2,AQAQPRVN
W !?80-$L(AQAQPRVC)/2,AQAQPRVC
W !!
F S AQAQPG=$O(^AQAQX(AQAQPT,"PG","B",AQAQPG)) Q:AQAQPG="" D
.K DIR S AQAQPN=0,DIR(0)="LO^0:"_AQAQPG
.F S AQAQPN=$O(^AQAQX(AQAQPT,"PG","B",AQAQPG,AQAQPN)) Q:AQAQPN="" D
..Q:'$D(^AQAQX(AQAQPT,"PG",AQAQPN,0))
..S AQAQPTL=$P(^AQAQX(AQAQPT,"PG",AQAQPN,0),U,3)
..S AQAQP(AQAQPG)=AQAQPTL_U_AQAQPN W !?5,AQAQPG,") ",AQAQPTL
..Q
;
;***> choose page to work on
W !!
S DIR("A")="Choose category to edit (Enter 0 for ALL categories)"
D ^DIR Q:$D(DIRUT) G PAGELOOP:Y=-1 S Y=$E(Y,1,$L(Y)-1)
I $D(^AQAQC(AQAQPRV,2)) S $P(^(2),U,3,4)=DT_U_DUZ ;editing user
;
;***> loop thru all pages selected
K DIROUT
S AQAQXLF(".")=",",Y=$$REPLACE^XLFSTR(Y,.AQAQXLF) K AQAQXLF ;PATCH #7
I Y=0 S AQAQO="" F S X=$O(AQAQP(X)) Q:X="" S AQAQO=AQAQO_","_X
E S AQAQO=Y
I AQAQO?1",".E S AQAQO=$E(AQAQO,2,99)
F AQAQ=1:1 S Y=$P(AQAQO,",",AQAQ) Q:Y="" Q:$D(DIROUT) Q:$D(DUOUT) D
.S AQAQPTL=$P(AQAQP(Y),U),AQAQPN=$P(AQAQP(Y),U,2)
.W @IOF,!?80-$L(AQAQPTL)/2,AQAQPTL ;page title
.W !?80-$L(AQAQPRVN)/2,AQAQPRVN ;print provider name
.W !?80-$L(AQAQPRVC)/2,AQAQPRVC,!! ;print provider class
.W $P(^AQAQX(AQAQPT,"PG",AQAQPN,0),U,4),! ;page heading
.K DIR S Y=$P(^AQAQX(AQAQPT,"PG",AQAQPN,0),U,2)
.I Y]"" S C=$P(^DD(9002166.11,.02,0),U,2) D Y^DIQ S (DIR("A"),AQAQDIR)=Y ;PATCH #7
.;
.;***> display items and ask user for choice, and then edit via ^die
.S AQAQTM=0
.S AQAQSTR=$S('$D(^AQAQX(AQAQPT,"PG",AQAQPN,1)):"",1:^(1))
.I $D(^AQAQX(AQAQPT,"PG",AQAQPN,2)) S DA=AQAQPRV X ^(2) Q ;IHS/ORDC/LJF 10/5/93 change for QAI pkg
.I $P(AQAQSTR,U)'="" D MULTFIND^AQAQEDTS Q ;multiple field page
.D ITEMFIND^AQAQEDTS:$P(AQAQSTR,U)="" ;multiple items on page
.Q
Q:$D(DIROUT) Q:X="^^"
G PAGELOOP
;>>end of PAGELOOP subrtn<<
AQAQEDT ;IHS/ANMC/LJF - MAIN DRIVER FOR DATA ENTRY; [ 09/15/95 8:46 AM ]
+1 ;;2.2;STAFF CREDENTIALS;**7**;01 OCT 1992
+2 ;
+3 ;This routine uses the QI Data Entry file to create data entry
+4 ;screens and controls editing of those screens.
+5 ;The calling option sends AQAQOPTN (option name) before calling rtn
+6 ;5/2/94 Routine modified to work with changes to QI Data Entry file
+7 ;needed by QAI Mgt. System. Distributed in patch AQAO*1*1.
+8 ;
SETOPT KILL DIC
SET X=AQAQOPTN
SET DIC(0)=""
SET DIC="^AQAQX("
+1 DO ^DIC
IF Y=-1
GOTO END
SET AQAQPT=+Y
+2 ;
+3 ;***> for each provider, choose pages and data items to enter/edit
+4 FOR
Begin DoDot:1
+5 DO GETPROV
IF X=U
QUIT
IF X=""
QUIT
+6 DO PAGELOOP
KILL DIRUT
End DoDot:1
IF $DATA(DIRUT)
QUIT
IF Y=-1
QUIT
+7 ;
END ;***> eoj
+1 DO KILL^AQAQUTIL
QUIT
+2 ;
+3 ;>>>>END OF MAIN ROUTINE; SUBRTNS TO FOLLOW<<<<<
+4 ;
GETPROV ;>>subrtn ask for provider & find/create entry in Credentialing file<<
+1 ;***> ask provider name
+2 KILL DIC
SET DIC("A")="Select PROVIDER NAME: "
SET DIC(0)="AELMQZ"
+3 SET (DIC,DLAYGO)=9002165
DO ^DIC
+4 IF X=U
QUIT
IF X=""
QUIT
IF Y=-1
GOTO GETPROV
SET AQAQPRV=+Y
+5 ;provider name
SET AQAQPRVN=$PIECE(^DIC(16,AQAQPRV,0),U)
+6 SET AQAQPRVC=""
SET Y=$PIECE($GET(^DIC(6,AQAQPRV,0)),U,4)
+7 ;provider class
IF Y]""
SET C=$PIECE(^DD(6,2,0),U,2)
DO Y^DIQ
SET AQAQPRVC=Y
+8 QUIT
+9 ;
+10 ;
PAGELOOP ;>>subrtn to get each page (screen), display items and do edit<<
+1 ;***> find all pages available to work on
+2 SET AQAQPG=0
SET AQAQOPTT=$PIECE(^AQAQX(AQAQPT,0),U,2)
+3 WRITE @IOF,!?80-$LENGTH(AQAQOPTT)/2,AQAQOPTT
+4 WRITE !?80-$LENGTH(AQAQPRVN)/2,AQAQPRVN
+5 WRITE !?80-$LENGTH(AQAQPRVC)/2,AQAQPRVC
+6 WRITE !!
+7 FOR
SET AQAQPG=$ORDER(^AQAQX(AQAQPT,"PG","B",AQAQPG))
IF AQAQPG=""
QUIT
Begin DoDot:1
+8 KILL DIR
SET AQAQPN=0
SET DIR(0)="LO^0:"_AQAQPG
+9 FOR
SET AQAQPN=$ORDER(^AQAQX(AQAQPT,"PG","B",AQAQPG,AQAQPN))
IF AQAQPN=""
QUIT
Begin DoDot:2
+10 IF '$DATA(^AQAQX(AQAQPT,"PG",AQAQPN,0))
QUIT
+11 SET AQAQPTL=$PIECE(^AQAQX(AQAQPT,"PG",AQAQPN,0),U,3)
+12 SET AQAQP(AQAQPG)=AQAQPTL_U_AQAQPN
WRITE !?5,AQAQPG,") ",AQAQPTL
+13 QUIT
End DoDot:2
End DoDot:1
+14 ;
+15 ;***> choose page to work on
+16 WRITE !!
+17 SET DIR("A")="Choose category to edit (Enter 0 for ALL categories)"
+18 DO ^DIR
IF $DATA(DIRUT)
QUIT
IF Y=-1
GOTO PAGELOOP
SET Y=$EXTRACT(Y,1,$LENGTH(Y)-1)
+19 ;editing user
IF $DATA(^AQAQC(AQAQPRV,2))
SET $PIECE(^(2),U,3,4)=DT_U_DUZ
+20 ;
+21 ;***> loop thru all pages selected
+22 KILL DIROUT
+23 ;PATCH #7
SET AQAQXLF(".")=","
SET Y=$$REPLACE^XLFSTR(Y,.AQAQXLF)
KILL AQAQXLF
+24 IF Y=0
SET AQAQO=""
FOR
SET X=$ORDER(AQAQP(X))
IF X=""
QUIT
SET AQAQO=AQAQO_","_X
+25 IF '$TEST
SET AQAQO=Y
+26 IF AQAQO?1",".E
SET AQAQO=$EXTRACT(AQAQO,2,99)
+27 FOR AQAQ=1:1
SET Y=$PIECE(AQAQO,",",AQAQ)
IF Y=""
QUIT
IF $DATA(DIROUT)
QUIT
IF $DATA(DUOUT)
QUIT
Begin DoDot:1
+28 SET AQAQPTL=$PIECE(AQAQP(Y),U)
SET AQAQPN=$PIECE(AQAQP(Y),U,2)
+29 ;page title
WRITE @IOF,!?80-$LENGTH(AQAQPTL)/2,AQAQPTL
+30 ;print provider name
WRITE !?80-$LENGTH(AQAQPRVN)/2,AQAQPRVN
+31 ;print provider class
WRITE !?80-$LENGTH(AQAQPRVC)/2,AQAQPRVC,!!
+32 ;page heading
WRITE $PIECE(^AQAQX(AQAQPT,"PG",AQAQPN,0),U,4),!
+33 KILL DIR
SET Y=$PIECE(^AQAQX(AQAQPT,"PG",AQAQPN,0),U,2)
+34 ;PATCH #7
IF Y]""
SET C=$PIECE(^DD(9002166.11,.02,0),U,2)
DO Y^DIQ
SET (DIR("A"),AQAQDIR)=Y
+35 ;
+36 ;***> display items and ask user for choice, and then edit via ^die
+37 SET AQAQTM=0
+38 SET AQAQSTR=$SELECT('$DATA(^AQAQX(AQAQPT,"PG",AQAQPN,1)):"",1:^(1))
+39 ;IHS/ORDC/LJF 10/5/93 change for QAI pkg
IF $DATA(^AQAQX(AQAQPT,"PG",AQAQPN,2))
SET DA=AQAQPRV
XECUTE ^(2)
QUIT
+40 ;multiple field page
IF $PIECE(AQAQSTR,U)'=""
DO MULTFIND^AQAQEDTS
QUIT
+41 ;multiple items on page
IF $PIECE(AQAQSTR,U)=""
DO ITEMFIND^AQAQEDTS
+42 QUIT
End DoDot:1
+43 IF $DATA(DIROUT)
QUIT
IF X="^^"
QUIT
+44 GOTO PAGELOOP
+45 ;>>end of PAGELOOP subrtn<<
