Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGSAUTL

DGSAUTL.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. Q
  1. ;
  1. EN(ORG) ;-- Entry point to Add/Edit Sharing Agreement Sub-Categories
  1. ;
  1. ; ORG - This parameter specifies the originating process
  1. ; "SD" - Appointment Type, "DG" - Admitting Regulation
  1. ;
  1. ;-- get the appropriate Admitting Reg or Appointment Type
  1. N DGAPT,DGCAT
  1. ;
  1. S DGAPT=$$GET(ORG)
  1. ;-- if no selection quit
  1. I DGAPT'>0 G ENQ
  1. ;-- get category
  1. S DGCAT=$$CAT(ORG)
  1. I DGCAT'>0 G ENQ
  1. ;-- put it all together
  1. D GOGO(ORG,DGAPT,DGCAT)
  1. ENQ ;
  1. Q
  1. ;
  1. GOGO(ORG,ATR,CAT) ;-- This function does something
  1. ;
  1. I ORG=""!(ATR'>0)!(CAT'>0) G GOGOQ
  1. ;
  1. N DGX,DA
  1. S DGX=$S(ORG="SD":"AT",1:"AR"),DIC("V")=$S(ORG="SD":"I +Y(0)=409.1",1:"I +Y(0)=43.4")
  1. S DA=$O(^DG(35.1,DGX,+ATR,+CAT,0))
  1. I DA D
  1. . N DGEDMODE S DIE="^DG(35.1,",DR="[DGSHARESUB]" D ^DIE
  1. E D
  1. .S X=+ATR_";"_$S(ORG="SD":"SD(409.1,",1:"DIC(43.4,")
  1. . S (DIC,DIK)="^DG(35.1,",DIC(0)="L",DLAYGO=35.1
  1. . S DIC("DR")=".02////"_+CAT_";.03"
  1. .K DD,DO D FILE^DICN
  1. ;
  1. GOGOQ K DIE,DIC
  1. Q
  1. ;
  1. GET(ORG) ;-- This function will get the appropriate App Type or Admit Reg
  1. N DGX
  1. S:ORG="SD" DGX=$$GETAT
  1. S:ORG="DG" DGX=$$GETAR
  1. Q DGX
  1. ;
  1. GETAT() ;-- get appointment type
  1. K DIC,Y
  1. S DIC="^SD(409.1,"
  1. S DIC("S")="I +$P(^(0),U,3)=0"
  1. S DIC(0)="AEZNQ"
  1. D ^DIC
  1. K DIC
  1. Q $G(Y)
  1. ;
  1. GETAR() ;-- get admitting regulation
  1. N DIC,Y
  1. S DIC="^DIC(43.4,"
  1. S DIC("S")="I +$P(^(0),U,4)=0"
  1. S DIC(0)="AEZNQ"
  1. D ^DIC
  1. K DIC
  1. Q $G(Y)
  1. ;
  1. CAT(DGORG) ;
  1. N DIC,Y
  1. ;-- get category from 35.2
  1. S DIC="^DG(35.2,"
  1. S DIC(0)="SLAEZQ"
  1. D ^DIC
  1. K DIC
  1. Q $G(Y)
  1. ;
  1. HLP ;-- help for Sub-Category file
  1. ;
  1. I '$D(DGAPT)!('$D(DGORG)) G HLPQ
  1. ;
  1. N DGX,DGI,DGJ
  1. S DGJ=1
  1. S DGX=$S(DGORG="SD":"AT",1:"AR")
  1. S DGI=0 F S DGI=$O(^DG(35.1,DGX,+DGAPT,DGI)) Q:'DGI S DGK=$O(^(DGI,0)) D
  1. . I DGORG="SD" D
  1. .. I DGJ W !,"APPOINTMENT TYPE :",$P(DGAPT,U,2),!,?5,"CATEGORY :" S DGJ=0
  1. . I DGORG="DG" D
  1. .. I DGJ W !,"VA ADMITTING REGULATION :",$P(DGAPT,U,2),!,?5,"CATEGORY :" S DGJ=0
  1. . 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")
  1. HLPQ ;
  1. Q
  1. ;
  1. ADCAT(ADCAT) ;-- This function will prompt the user for the category
  1. ; associated with the admitting regulation selected.
  1. ;
  1. N RESULT,DGSA
  1. S RESULT=$$SUB(ADCAT,1,$P($G(^DGPM(+$G(DA),"PTF")),U,4))
  1. Q RESULT
  1. ;
  1. GETSA(ATAR,SOURCE,ACTIVE) ;-- This function will build the DGSA array containing all the
  1. ; sub-categories associated with an admitting reg.
  1. ;
  1. ;
  1. Q:'$G(ATAR)
  1. N DGX,DGY
  1. S DGY=1,DGX=0 F S DGX=$O(^DG(35.1,$S(SOURCE=1:"AR",1:"AT"),ATAR,DGX)) Q:'DGX D
  1. . N DGSCREEN S DGSCREEN=1 I $G(ACTIVE) S DGSCREEN=+$O(^(DGX,0)),DGSCREEN=$P($G(^DG(35.1,DGSCREEN,0)),U,3)
  1. . I DGSCREEN S DGSA(1,DGX)=DGX_U_$P($G(^DG(35.2,DGX,0)),U)
  1. Q
  1. ;
  1. SUB(ATAR,SOURCE,DEFAULT) ;-- This function will check and prompt for sharing
  1. ; agreement sub-categories associated with either an Admitting Reg
  1. ; or a Appointment Type.
  1. ;
  1. ; INPUT: ATAR - IEN if Admitting Reg or Appointment Type
  1. ; SOURCE - (1:ADT,2:SCHEDULING)
  1. ; DEFAULT - IEN from file 35.2
  1. ; OUTPUT: IEN of file 35.2^Name
  1. ;
  1. ;
  1. N RESULT,ALLEL,EMP,X,DGDEF,Y
  1. ;
  1. ;-- get eligibility codes
  1. D GETSA(ATAR,SOURCE,1)
  1. S DGDEF=$P($G(^DG(35.2,+$G(DEFAULT),0)),U)
  1. I DGDEF'="" S DGDEF=DEFAULT_U_DGDEF
  1. ;
  1. S RESULT=""
  1. ;
  1. I '$D(DGSA) G SUBQ
  1. S X=0,X=$O(DGSA(1,X))
  1. I '$O(DGSA(1,X)) S RESULT=DGSA(1,X) G SUBQ
  1. ;-- if no default set default to first entry
  1. I DGDEF="" S DGDEF=DGSA(1,X)
  1. ;
  1. DISP ;-- display choices
  1. ;
  1. S ALLEL=""
  1. ;-- get the name of the Admitting Reg or Appointment Type
  1. I SOURCE=1 S DGNAME=$P($G(^DIC(43.4,ATAR,0)),U)
  1. E S DGNAME=$P($G(^SD(409.1,ATAR,0)),U)
  1. ;
  1. W !,"THE ["_DGNAME_$S(SOURCE=1:"] ADMITTING REGULATION",1:"] APPOINTMENT TYPE")
  1. W !,"HAS THE FOLLOWING SUB-CATEGORIES DEFINED."
  1. S X="" F S X=$O(DGSA(1,X)) Q:'X D
  1. . W !?5,$P(DGSA(1,X),U,2)
  1. . S ALLEL=ALLEL_U_$P(DGSA(1,X),U,2)
  1. ;
  1. ;-- prompt for sub-categories
  1. ;
  1. 1 W !,"ENTER THE SUB-CAT FOR THE ["_DGNAME_$S(SOURCE=1:"] ADMITTING REG",1:"] APPT TYPE")_": "_$P(DGDEF,U,2)_"// "
  1. R X:DTIME
  1. ;-- if timeout
  1. G SUBQ:'$T
  1. ;-- if ^
  1. G SUBQ:X[U
  1. ;-- if default (primary) quit
  1. I X="" S RESULT=DGDEF G SUBQ
  1. ;-- find eligibility
  1. S X=$$UPPER^VALM1(X)
  1. G DISP:X["?",1:ALLEL'[(U_X)
  1. N CNT,RES S CNT=0
  1. S EMP=X ;_$P($P(ALLEL,U_X,2),U) ;W $P($P(ALLEL,U_X,2),U)
  1. S X="" F S X=$O(DGSA(1,X)) Q:X'>0 D
  1. . 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)
  1. W:CNT=1 $P($P(ALLEL,U_EMP,2),U) I CNT>1 D G 1:(('RESULT)&(X'[U))
  1. .N I F I=1:1:CNT W !?5,I_" "_$P(RES(I),U,2)
  1. .W !,"CHOOSE 1 - "_CNT_": "
  1. .S RESULT="" R X:DTIME I $D(RES(+X)) S RESULT=RES(+X) W " "_$P(RES(+X),U,2)
  1. SUBQ ;
  1. K DGSA
  1. S RESULT=$P(RESULT,U)
  1. ;Q +RESULT
  1. ;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
  1. Q RESULT