DGSAUTL ;ALB/MTC - SHARING AGREEMENTS UTILITY FUNCTIONS ; 16 JAN 97
;;5.3;Registration;**114,194,216***,1015**;Aug 13, 1993;Build 21
;
Q
;
EN(ORG) ;-- Entry point to Add/Edit Sharing Agreement Sub-Categories
;
; ORG - This parameter specifies the orginating process
; "SD" - Appointment Type, "DG" - Admitting Regulation
;
;-- get the appropriate Admitting Reg or Appoitment Type
N DGAPT,DGCAT
;
S DGAPT=$$GET(ORG)
;-- if no selection quit
I DGAPT'>0 G ENQ
;-- get category
S DGCAT=$$CAT(ORG)
I DGCAT'>0 G ENQ
;-- put it all together
D GOGO(ORG,DGAPT,DGCAT)
ENQ ;
Q
;
GOGO(ORG,ATR,CAT) ;-- This function does something
;
I ORG=""!(ATR'>0)!(CAT'>0) G GOGOQ
;
N DGX,DA
S DGX=$S(ORG="SD":"AT",1:"AR"),DIC("V")=$S(ORG="SD":"I +Y(0)=409.1",1:"I +Y(0)=43.4")
S DA=$O(^DG(35.1,DGX,+ATR,+CAT,0))
I DA D
. N DGEDMODE S DIE="^DG(35.1,",DR="[DGSHARESUB]" D ^DIE
E D
.S X=+ATR_";"_$S(ORG="SD":"SD(409.1,",1:"DIC(43.4,")
. S (DIC,DIK)="^DG(35.1,",DIC(0)="L",DLAYGO=35.1
. S DIC("DR")=".02////"_+CAT_";.03"
.K DD,DO D FILE^DICN
;
GOGOQ K DIE,DIC
Q
;
GET(ORG) ;-- This function will get the appropriate App Type or Admit Reg
N DGX
S:ORG="SD" DGX=$$GETAT
S:ORG="DG" DGX=$$GETAR
Q DGX
;
GETAT() ;-- get appointment type
K DIC,Y
S DIC="^SD(409.1,"
S DIC("S")="I +$P(^(0),U,3)=0"
S DIC(0)="AEZNQ"
D ^DIC
K DIC
Q $G(Y)
;
GETAR() ;-- get admitting regulation
N DIC,Y
S DIC="^DIC(43.4,"
S DIC("S")="I +$P(^(0),U,4)=0"
S DIC(0)="AEZNQ"
D ^DIC
K DIC
Q $G(Y)
;
CAT(DGORG) ;
N DIC,Y
;-- get category from 35.2
S DIC="^DG(35.2,"
S DIC(0)="SLAEZQ"
D ^DIC
K DIC
Q $G(Y)
;
HLP ;-- help for Sub-Category file
;
I '$D(DGAPT)!('$D(DGORG)) G HLPQ
;
N DGX,DGI,DGJ
S DGJ=1
S DGX=$S(DGORG="SD":"AT",1:"AR")
S DGI=0 F S DGI=$O(^DG(35.1,DGX,+DGAPT,DGI)) Q:'DGI S DGK=$O(^(DGI,0)) D
. I DGORG="SD" D
.. I DGJ W !,"APPOINTMENT TYPE :",$P(DGAPT,U,2),!,?5,"CATEGORY :" S DGJ=0
. I DGORG="DG" D
.. I DGJ W !,"VA ADMITTING REGULATION :",$P(DGAPT,U,2),!,?5,"CATEGORY :" S DGJ=0
. W !,?10,$P(^DG(35.2,$P(^DG(35.1,DGK,0),U,2),0),U),?35,$S($P(^DG(35.1,DGK,0),U,3)=1:"ACTIVE",1:"INACTIVE")
HLPQ ;
Q
;
ADCAT(ADCAT) ;-- This function will prompt the user for the category
; associated with the admitting regulation selected.
;
N RESULT,DGSA
S RESULT=$$SUB(ADCAT,1,$P($G(^DGPM(+$G(DA),"PTF")),U,4))
Q RESULT
;
GETSA(ATAR,SOURCE,ACTIVE) ;-- This function will build the DGSA array containing all the
; sub-categories associated with an admitting reg.
;
;
Q:'$G(ATAR)
N DGX,DGY
S DGY=1,DGX=0 F S DGX=$O(^DG(35.1,$S(SOURCE=1:"AR",1:"AT"),ATAR,DGX)) Q:'DGX D
. N DGSCREEN S DGSCREEN=1 I $G(ACTIVE) S DGSCREEN=+$O(^(DGX,0)),DGSCREEN=$P($G(^DG(35.1,DGSCREEN,0)),U,3)
. I DGSCREEN S DGSA(1,DGX)=DGX_U_$P($G(^DG(35.2,DGX,0)),U)
Q
;
SUB(ATAR,SOURCE,DEFAULT) ;-- This function will check and prompt for sharing
; agreement sub-categories associated with either an Admitting Reg
; or a Appointment Type.
;
; INPUT: ATAR - IEN if Admitting Reg or Appointment Type
; SOURCE - (1:ADT,2:SCHEDULING)
; DEFALUT - IEN from file 35.2
; OUTPUT: IEN of file 35.2^Name
;
;
N RESULT,ALLEL,EMP,X,DGDEF,Y
;
;-- get eligility codes
D GETSA(ATAR,SOURCE,1)
S DGDEF=$P($G(^DG(35.2,+$G(DEFAULT),0)),U)
I DGDEF'="" S DGDEF=DEFAULT_U_DGDEF
;
S RESULT=""
I '$D(DGSA) G SUBQ
S X=0,X=$O(DGSA(1,X))
I '$O(DGSA(1,X)) S RESULT=DGSA(1,X) G SUBQ
;-- if no default set default to first entry
I DGDEF="" S DGDEF=DGSA(1,X)
;
DISP ;-- display choices
;
S ALLEL=""
;-- get the name of the Admitting Reg or Appointment Type
I SOURCE=1 S DGNAME=$P($G(^DIC(43.4,ATAR,0)),U)
E S DGNAME=$P($G(^SD(409.1,ATAR,0)),U)
;
W !,"THE ["_DGNAME_$S(SOURCE=1:"] ADMITTING REGULATION",1:"] APPOINTMENT TYPE")
W !,"HAS THE FOLLOWING SUB-CATEGORIES DEFINED."
S X="" F S X=$O(DGSA(1,X)) Q:'X D
. W !?5,$P(DGSA(1,X),U,2)
. S ALLEL=ALLEL_U_$P(DGSA(1,X),U,2)
;
;-- prompt for sub-categories
;
1 W !,"ENTER THE SUB-CAT FOR THE ["_DGNAME_$S(SOURCE=1:"] ADMITTING REG",1:"] APPT TYPE")_": "_$P(DGDEF,U,2)_"// "
R X:DTIME
;-- if timeout
G SUBQ:'$T
;-- if ^
G SUBQ:X[U
;-- if default (primary) quit
I X="" S RESULT=DGDEF G SUBQ
;-- find eligibility
S X=$$UPPER^VALM1(X)
G DISP:X["?",1:ALLEL'[(U_X)
N CNT,RES S CNT=0
S EMP=X ;_$P($P(ALLEL,U_X,2),U) ;W $P($P(ALLEL,U_X,2),U)
S X="" F S X=$O(DGSA(1,X)) Q:X'>0 D
. I $E($P(DGSA(1,X),U,2),1,$L(EMP))=EMP S CNT=CNT+1,(RES(CNT),RESULT)=X_U_$P(DGSA(1,X),U,2)
W:CNT=1 $P($P(ALLEL,U_EMP,2),U) I CNT>1 D G 1:(('RESULT)&(X'[U))
.N I F I=1:1:CNT W !?5,I_" "_$P(RES(I),U,2)
.W !,"CHOOSE 1 - "_CNT_": "
.S RESULT="" R X:DTIME I $D(RES(+X)) S RESULT=RES(+X) W " "_$P(RES(+X),U,2)
SUBQ ;
K DGSA
Q +RESULT
;
DGSAUTL ;ALB/MTC - SHARING AGREEMENTS UTILITY FUNCTIONS ; 16 JAN 97
+1 ;;5.3;Registration;**114,194,216***,1015**;Aug 13, 1993;Build 21
+2 ;
+3 QUIT
+4 ;
EN(ORG) ;-- Entry point to Add/Edit Sharing Agreement Sub-Categories
+1 ;
+2 ; ORG - This parameter specifies the orginating process
+3 ; "SD" - Appointment Type, "DG" - Admitting Regulation
+4 ;
+5 ;-- get the appropriate Admitting Reg or Appoitment Type
+6 NEW DGAPT,DGCAT
+7 ;
+8 SET DGAPT=$$GET(ORG)
+9 ;-- if no selection quit
+10 IF DGAPT'>0
GOTO ENQ
+11 ;-- get category
+12 SET DGCAT=$$CAT(ORG)
+13 IF DGCAT'>0
GOTO ENQ
+14 ;-- put it all together
+15 DO GOGO(ORG,DGAPT,DGCAT)
ENQ ;
+1 QUIT
+2 ;
GOGO(ORG,ATR,CAT) ;-- This function does something
+1 ;
+2 IF ORG=""!(ATR'>0)!(CAT'>0)
GOTO GOGOQ
+3 ;
+4 NEW DGX,DA
+5 SET DGX=$SELECT(ORG="SD":"AT",1:"AR")
SET DIC("V")=$SELECT(ORG="SD":"I +Y(0)=409.1",1:"I +Y(0)=43.4")
+6 SET DA=$ORDER(^DG(35.1,DGX,+ATR,+CAT,0))
+7 IF DA
Begin DoDot:1
+8 NEW DGEDMODE
SET DIE="^DG(35.1,"
SET DR="[DGSHARESUB]"
DO ^DIE
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET X=+ATR_";"_$SELECT(ORG="SD":"SD(409.1,",1:"DIC(43.4,")
+11 SET (DIC,DIK)="^DG(35.1,"
SET DIC(0)="L"
SET DLAYGO=35.1
+12 SET DIC("DR")=".02////"_+CAT_";.03"
+13 KILL DD,DO
DO FILE^DICN
End DoDot:1
+14 ;
GOGOQ KILL DIE,DIC
+1 QUIT
+2 ;
GET(ORG) ;-- This function will get the appropriate App Type or Admit Reg
+1 NEW DGX
+2 IF ORG="SD"
SET DGX=$$GETAT
+3 IF ORG="DG"
SET DGX=$$GETAR
+4 QUIT DGX
+5 ;
GETAT() ;-- get appointment type
+1 KILL DIC,Y
+2 SET DIC="^SD(409.1,"
+3 SET DIC("S")="I +$P(^(0),U,3)=0"
+4 SET DIC(0)="AEZNQ"
+5 DO ^DIC
+6 KILL DIC
+7 QUIT $GET(Y)
+8 ;
GETAR() ;-- get admitting regulation
+1 NEW DIC,Y
+2 SET DIC="^DIC(43.4,"
+3 SET DIC("S")="I +$P(^(0),U,4)=0"
+4 SET DIC(0)="AEZNQ"
+5 DO ^DIC
+6 KILL DIC
+7 QUIT $GET(Y)
+8 ;
CAT(DGORG) ;
+1 NEW DIC,Y
+2 ;-- get category from 35.2
+3 SET DIC="^DG(35.2,"
+4 SET DIC(0)="SLAEZQ"
+5 DO ^DIC
+6 KILL DIC
+7 QUIT $GET(Y)
+8 ;
HLP ;-- help for Sub-Category file
+1 ;
+2 IF '$DATA(DGAPT)!('$DATA(DGORG))
GOTO HLPQ
+3 ;
+4 NEW DGX,DGI,DGJ
+5 SET DGJ=1
+6 SET DGX=$SELECT(DGORG="SD":"AT",1:"AR")
+7 SET DGI=0
FOR
SET DGI=$ORDER(^DG(35.1,DGX,+DGAPT,DGI))
IF 'DGI
QUIT
SET DGK=$ORDER(^(DGI,0))
Begin DoDot:1
+8 IF DGORG="SD"
Begin DoDot:2
+9 IF DGJ
WRITE !,"APPOINTMENT TYPE :",$PIECE(DGAPT,U,2),!,?5,"CATEGORY :"
SET DGJ=0
End DoDot:2
+10 IF DGORG="DG"
Begin DoDot:2
+11 IF DGJ
WRITE !,"VA ADMITTING REGULATION :",$PIECE(DGAPT,U,2),!,?5,"CATEGORY :"
SET DGJ=0
End DoDot:2
+12 WRITE !,?10,$PIECE(^DG(35.2,$PIECE(^DG(35.1,DGK,0),U,2),0),U),?35,$SELECT($PIECE(^DG(35.1,DGK,0),U,3)=1:"ACTIVE",1:"INACTIVE")
End DoDot:1
HLPQ ;
+1 QUIT
+2 ;
ADCAT(ADCAT) ;-- This function will prompt the user for the category
+1 ; associated with the admitting regulation selected.
+2 ;
+3 NEW RESULT,DGSA
+4 SET RESULT=$$SUB(ADCAT,1,$PIECE($GET(^DGPM(+$GET(DA),"PTF")),U,4))
+5 QUIT RESULT
+6 ;
GETSA(ATAR,SOURCE,ACTIVE) ;-- This function will build the DGSA array containing all the
+1 ; sub-categories associated with an admitting reg.
+2 ;
+3 ;
+4 IF '$GET(ATAR)
QUIT
+5 NEW DGX,DGY
+6 SET DGY=1
SET DGX=0
FOR
SET DGX=$ORDER(^DG(35.1,$SELECT(SOURCE=1:"AR",1:"AT"),ATAR,DGX))
IF 'DGX
QUIT
Begin DoDot:1
+7 NEW DGSCREEN
SET DGSCREEN=1
IF $GET(ACTIVE)
SET DGSCREEN=+$ORDER(^(DGX,0))
SET DGSCREEN=$PIECE($GET(^DG(35.1,DGSCREEN,0)),U,3)
+8 IF DGSCREEN
SET DGSA(1,DGX)=DGX_U_$PIECE($GET(^DG(35.2,DGX,0)),U)
End DoDot:1
+9 QUIT
+10 ;
SUB(ATAR,SOURCE,DEFAULT) ;-- This function will check and prompt for sharing
+1 ; agreement sub-categories associated with either an Admitting Reg
+2 ; or a Appointment Type.
+3 ;
+4 ; INPUT: ATAR - IEN if Admitting Reg or Appointment Type
+5 ; SOURCE - (1:ADT,2:SCHEDULING)
+6 ; DEFALUT - IEN from file 35.2
+7 ; OUTPUT: IEN of file 35.2^Name
+8 ;
+9 ;
+10 NEW RESULT,ALLEL,EMP,X,DGDEF,Y
+11 ;
+12 ;-- get eligility codes
+13 DO GETSA(ATAR,SOURCE,1)
+14 SET DGDEF=$PIECE($GET(^DG(35.2,+$GET(DEFAULT),0)),U)
+15 IF DGDEF'=""
SET DGDEF=DEFAULT_U_DGDEF
+16 ;
+17 SET RESULT=""
+18 IF '$DATA(DGSA)
GOTO SUBQ
+19 SET X=0
SET X=$ORDER(DGSA(1,X))
+20 IF '$ORDER(DGSA(1,X))
SET RESULT=DGSA(1,X)
GOTO SUBQ
+21 ;-- if no default set default to first entry
+22 IF DGDEF=""
SET DGDEF=DGSA(1,X)
+23 ;
DISP ;-- display choices
+1 ;
+2 SET ALLEL=""
+3 ;-- get the name of the Admitting Reg or Appointment Type
+4 IF SOURCE=1
SET DGNAME=$PIECE($GET(^DIC(43.4,ATAR,0)),U)
+5 IF '$TEST
SET DGNAME=$PIECE($GET(^SD(409.1,ATAR,0)),U)
+6 ;
+7 WRITE !,"THE ["_DGNAME_$SELECT(SOURCE=1:"] ADMITTING REGULATION",1:"] APPOINTMENT TYPE")
+8 WRITE !,"HAS THE FOLLOWING SUB-CATEGORIES DEFINED."
+9 SET X=""
FOR
SET X=$ORDER(DGSA(1,X))
IF 'X
QUIT
Begin DoDot:1
+10 WRITE !?5,$PIECE(DGSA(1,X),U,2)
+11 SET ALLEL=ALLEL_U_$PIECE(DGSA(1,X),U,2)
End DoDot:1
+12 ;
+13 ;-- prompt for sub-categories
+14 ;
1 WRITE !,"ENTER THE SUB-CAT FOR THE ["_DGNAME_$SELECT(SOURCE=1:"] ADMITTING REG",1:"] APPT TYPE")_": "_$PIECE(DGDEF,U,2)_"// "
+1 READ X:DTIME
+2 ;-- if timeout
+3 IF '$TEST
GOTO SUBQ
+4 ;-- if ^
+5 IF X[U
GOTO SUBQ
+6 ;-- if default (primary) quit
+7 IF X=""
SET RESULT=DGDEF
GOTO SUBQ
+8 ;-- find eligibility
+9 SET X=$$UPPER^VALM1(X)
+10 IF X["?"
GOTO DISP
IF ALLEL'[(U_X)
GOTO 1
+11 NEW CNT,RES
SET CNT=0
+12 ;_$P($P(ALLEL,U_X,2),U) ;W $P($P(ALLEL,U_X,2),U)
SET EMP=X
+13 SET X=""
FOR
SET X=$ORDER(DGSA(1,X))
IF X'>0
QUIT
Begin DoDot:1
+14 IF $EXTRACT($PIECE(DGSA(1,X),U,2),1,$LENGTH(EMP))=EMP
SET CNT=CNT+1
SET (RES(CNT),RESULT)=X_U_$PIECE(DGSA(1,X),U,2)
End DoDot:1
+15 IF CNT=1
WRITE $PIECE($PIECE(ALLEL,U_EMP,2),U)
IF CNT>1
Begin DoDot:1
+16 NEW I
FOR I=1:1:CNT
WRITE !?5,I_" "_$PIECE(RES(I),U,2)
+17 WRITE !,"CHOOSE 1 - "_CNT_": "
+18 SET RESULT=""
READ X:DTIME
IF $DATA(RES(+X))
SET RESULT=RES(+X)
WRITE " "_$PIECE(RES(+X),U,2)
End DoDot:1
IF (('RESULT)&(X'[U))
GOTO 1
SUBQ ;
+1 KILL DGSA
+2 QUIT +RESULT
+3 ;
