- DGSAUTL ;ALB/MTC - SHARING AGREEMENTS UTILITY FUNCTIONS ; 9/12/13 9:54am
- ;;5.3;Registration;**114,194,216,872**;Aug 13, 1993;Build 28
- ;
- Q
- ;
- EN(ORG) ;-- Entry point to Add/Edit Sharing Agreement Sub-Categories
- ;
- ; ORG - This parameter specifies the originating process
- ; "SD" - Appointment Type, "DG" - Admitting Regulation
- ;
- ;-- get the appropriate Admitting Reg or Appointment 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)
- ; DEFAULT - IEN from file 35.2
- ; OUTPUT: IEN of file 35.2^Name
- ;
- ;
- N RESULT,ALLEL,EMP,X,DGDEF,Y
- ;
- ;-- get eligibility 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
- S RESULT=$P(RESULT,U)
- ;Q +RESULT
- ;returning null if no result, to populate pointer field appt. type subcategory(.14)of the appt. sub-file(2.98) of the patient file(2) correctly. Patch 872
- Q RESULT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGSAUTL 5087 printed Feb 19, 2025@00:24:48 Page 2
- DGSAUTL ;ALB/MTC - SHARING AGREEMENTS UTILITY FUNCTIONS ; 9/12/13 9:54am
- +1 ;;5.3;Registration;**114,194,216,872**;Aug 13, 1993;Build 28
- +2 ;
- +3 QUIT
- +4 ;
- EN(ORG) ;-- Entry point to Add/Edit Sharing Agreement Sub-Categories
- +1 ;
- +2 ; ORG - This parameter specifies the originating process
- +3 ; "SD" - Appointment Type, "DG" - Admitting Regulation
- +4 ;
- +5 ;-- get the appropriate Admitting Reg or Appointment 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 ; DEFAULT - 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 eligibility 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 ;
- +19 IF '$DATA(DGSA)
- GOTO SUBQ
- +20 SET X=0
- SET X=$ORDER(DGSA(1,X))
- +21 IF '$ORDER(DGSA(1,X))
- SET RESULT=DGSA(1,X)
- GOTO SUBQ
- +22 ;-- if no default set default to first entry
- +23 IF DGDEF=""
- SET DGDEF=DGSA(1,X)
- +24 ;
- 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 SET RESULT=$PIECE(RESULT,U)
- +3 ;Q +RESULT
- +4 ;returning null if no result, to populate pointer field appt. type subcategory(.14)of the appt. sub-file(2.98) of the patient file(2) correctly. Patch 872
- +5 QUIT RESULT