- ADEGRL5A ; IHS/HQT/MJL - CODE EDITS ; [ 03/24/1999 9:04 AM ]
- ;;6.0;ADE;**23**;JUN 6, 2011
- ;IHS/HMW 10-31-91 HAPPY HALLOWEEN
- ;INPUTS - ADEV(ADECOD),ADEHX ARRAY
- ;$O THRU ^ADEDIT("AC",ADECOD,RESOLUTION TYPE,ENTRY NUMBER)
- ;DO SUBR CORRESPONDING TO EDIT TYPE - RESOLVE PRN
- ;OUTPUT - FLAG ON ADA CODE, REJECT ADA CODE, REPLACE ADA CODE
- ;
- ;FHL 9/9/98 B
- CTRL N ADERTYP,ADERDFN,ADENOD,ADEDTYP,ADECONF,ADELIM,ADEJJ,ADEVFM,ADEPC
- G:'$D(^ADEDIT("AC",ADECOD)) EXIT
- RES ;$O THRU RESOLUTION TYPE XREF
- S ADERTYP=0
- F S ADERTYP=$O(^ADEDIT("AC",ADECOD,ADERTYP)) Q:'+ADERTYP D RES1 Q:'$D(ADEV(ADECOD))
- EXIT Q
- K ADERTYP,ADERDFN,ADENOD,ADEDTYP,ADECONF,ADELIM,ADEJJ,ADEVFM,ADEPC ;*NE
- K ADEKK ;*NE
- ;
- RES1 S ADERDFN=0
- F S ADERDFN=$O(^ADEDIT("AC",ADECOD,ADERTYP,ADERDFN)) Q:'+ADERDFN Q:'$D(ADEV(ADECOD)) D EDIT Q:'$D(ADEV(ADECOD))
- Q
- EDIT S ADENOD=^ADEDIT(ADERDFN,0)
- Q:$P(ADENOD,U,4)="n" ;FHL 9/9/98 ;edit not enabled
- S ADEDTYP=$P(ADENOD,U,2)
- I ADEDTYP=1 D E1
- I ADEDTYP=2 D E2
- I ADEDTYP=3 D E3
- I ADEDTYP=4 D E4
- Q
- E1 ;EDIT TYPE 1 -- INCOMPATIBLE CODES
- N ADEK,ADEPC,ADEVFM,ADEOP,ADEOPC,ADEKK
- ;FIRST GET LIST OF CODES
- S ADECONF=^ADEDIT(ADERDFN,1)
- I ADECONF["[" S ADECONF=$P(ADECONF,"[",2),ADECONF=^ADEDIT("GRP",$O(^ADEDIT("GRP","B",ADECONF,0)),1) ;W "ADECONF=",ADECONF H 1
- ;SEE IF CURRENT CODE ADECOD IS IN LIST - IF SO, RESOLVE
- I $P(^ADEDIT(ADERDFN,0),U,3)]"" D E1A ;Opsite specific
- I $P(^ADEDIT(ADERDFN,0),U,3)="" D E1B
- Q
- E1A F ADEKK=1:1:$L(ADECONF,"|") I $D(ADEV($P(ADECONF,"|",ADEKK))),$P(ADECONF,"|",ADEKK)'=ADECOD D
- . F Q:'$D(ADEV(ADECOD)) S ADEOP=$P(ADEV(ADECOD),U,2) S ADEPC=ADEOP_","_$P(ADEV($P(ADECONF,"|",ADEKK)),U,2) S ADEOPC=$$DUPE^ADEGRL5C(ADEPC) Q:'ADEOPC D RESOLVE^ADEGRL5B
- Q
- E1B S ADEJJ=0 F S ADEJJ=$O(ADEV(ADEJJ)) Q:ADEJJ="" I ADECOD'=ADEJJ,ADECONF[ADEJJ D RESOLVE^ADEGRL5B Q
- Q
- E2 ;EDIT TYPE 2 -- TIME LIMIT ON CODES
- N ADEK,ADEPC,ADEVFM,ADEOP,ADEOPC,ADEKK,ADEQTY
- S ADECONF=^ADEDIT(ADERDFN,1)
- I ADECONF["[" S ADECONF=$P(ADECONF,"[",2),ADECONF=^ADEDIT("GRP",$O(^ADEDIT("GRP","B",ADECONF,0)),1)
- S X=ADEVDATE,%DT="T" D ^%DT S (ADEVFM,X1)=Y K %DT,X,Y ;IHS/HMW **2**
- S X2=$P(^ADEDIT(ADERDFN,2),U)
- S X2=$TR(X2,"|",";") ;Delimiter may be | or ;
- S ADEQTY=$P(X2,";",2),X2=$P(X2,";")
- I X2="FY" D
- . ;Set ADELIM to beginning of FY
- . S ADELIM=$$FY^ADEUTL(ADEVDATE)
- E D
- . S X2=-X2
- . D C^%DTC S ADELIM=X K X
- ;
- ;$O THRU ADEHXC & SEE IF ANY OF THESE CODES HAVE DATES AFTER LIMIT TIME
- I $P(^ADEDIT(ADERDFN,0),U,3)]"" D E2A ;Opsite specific
- I $P(^ADEDIT(ADERDFN,0),U,3)="" D E2B
- Q
- E2A ;
- S ADEOP=$P(ADEV(ADECOD),U,2)
- F ADEK=1:1:$L(ADEOP,",") S ADEOPC=$P(ADEOP,",",ADEK) D E2A2 ;Q:$D(ADEXFLG)
- Q
- E2A2 F ADEKK=1:1:$L(ADECONF,"|") S ADEPC=$P(ADECONF,"|",ADEKK) I $D(ADEHXO(ADEOPC,ADEPC)),$O(ADEHXO(ADEOPC,ADEPC,ADELIM))]"",$O(ADEHXO(ADEOPC,ADEPC,ADELIM))<ADEVFM D E2A3 Q
- Q
- E2A3 N ADECNT,ADED
- S ADECNT=0,ADED=ADELIM
- F S ADED=$O(ADEHXO(ADEOPC,ADEPC,ADED)) Q:'+ADED Q:ADED>ADEVFM S ADECNT=ADECNT+1
- I ADECNT>(ADEQTY-1) D RESOLVE^ADEGRL5B
- Q
- E2B F ADEK=1:1:$L(ADECONF,"|") S ADEPC=$P(ADECONF,"|",ADEK) I $D(ADEHXC(ADEPC)),$O(ADEHXC(ADEPC,ADELIM))]"",$O(ADEHXC(ADEPC,ADELIM))<ADEVFM D RESOLVE^ADEGRL5B Q
- Q
- ;
- E3 ;Age Screen
- N ADEOP,ADEK,ADEPC,ADEOPC,ADETST
- ;FHL 9/9/98 B
- S ADETST=$P(^ADEDIT(ADERDFN,2),U,4)
- ;I @((AUPNDAYS\365.25)_"'"_$P(^ADEDIT(ADERDFN,2),U,4)) Q
- I $E(ADETST,1,1)=">"!($E(ADETST,1,1)="<") S ADETST="'(X"_ADETST_")"
- S X=AUPNDAYS\365.25
- I @ADETST Q
- ;
- I $P(^ADEDIT(ADERDFN,0),U,3)]"" D E3A ;Opsite specific
- I $P(^ADEDIT(ADERDFN,0),U,3)="" D RESOLVE^ADEGRL5B
- Q
- E3A S ADEOP=$P(ADEV(ADECOD),U,2)
- F ADEK=1:1:$L(ADEOP,",") S ADEOPC=$P(ADEOP,",",ADEK) D RESOLVE^ADEGRL5B
- Q
- E4 ;Permissible Opsites -use only with codes that require opsites
- ; and use only Resolution 1 (reject)
- N ADEPERM,ADEK,ADEOP,ADEOPC
- S ADEPERM=$P(^ADEDIT(ADERDFN,4),U)
- I ADEPERM["[" S ADEPERM=$P(ADEPERM,"[",2),ADEPERM=$O(^ADEDIT("GRP","B",ADEPERM,0)),ADEPERM=$P(^ADEDIT("GRP",ADEPERM,1),U)
- F ADEK=1:1:$L(ADEPERM,"|") D
- . S ADEPC=$P(ADEPERM,"|",ADEK)
- . S ADEPC=$O(^ADEOPS("B",ADEPC,0))
- . S:ADEPC ADEPERM(ADEPC)=""
- S ADEOP=$P(ADEV(ADECOD),U,2)
- Q:'ADEOP ;IHS;SD;TPF H31091 PATCH 23
- F ADEK=1:1:$L(ADEOP,",") S ADEOPC=$P(ADEOP,",",ADEK) D
- . I '$D(ADEPERM(ADEOPC)) D RESOLVE^ADEGRL5B
- Q
- K ADEPERM ;*NE
- ADEGRL5A ; IHS/HQT/MJL - CODE EDITS ; [ 03/24/1999 9:04 AM ]
- +1 ;;6.0;ADE;**23**;JUN 6, 2011
- +2 ;IHS/HMW 10-31-91 HAPPY HALLOWEEN
- +3 ;INPUTS - ADEV(ADECOD),ADEHX ARRAY
- +4 ;$O THRU ^ADEDIT("AC",ADECOD,RESOLUTION TYPE,ENTRY NUMBER)
- +5 ;DO SUBR CORRESPONDING TO EDIT TYPE - RESOLVE PRN
- +6 ;OUTPUT - FLAG ON ADA CODE, REJECT ADA CODE, REPLACE ADA CODE
- +7 ;
- +8 ;FHL 9/9/98 B
- CTRL NEW ADERTYP,ADERDFN,ADENOD,ADEDTYP,ADECONF,ADELIM,ADEJJ,ADEVFM,ADEPC
- +1 IF '$DATA(^ADEDIT("AC",ADECOD))
- GOTO EXIT
- RES ;$O THRU RESOLUTION TYPE XREF
- +1 SET ADERTYP=0
- +2 FOR
- SET ADERTYP=$ORDER(^ADEDIT("AC",ADECOD,ADERTYP))
- IF '+ADERTYP
- QUIT
- DO RES1
- IF '$DATA(ADEV(ADECOD))
- QUIT
- EXIT QUIT
- +1 ;*NE
- KILL ADERTYP,ADERDFN,ADENOD,ADEDTYP,ADECONF,ADELIM,ADEJJ,ADEVFM,ADEPC
- +2 ;*NE
- KILL ADEKK
- +3 ;
- RES1 SET ADERDFN=0
- +1 FOR
- SET ADERDFN=$ORDER(^ADEDIT("AC",ADECOD,ADERTYP,ADERDFN))
- IF '+ADERDFN
- QUIT
- IF '$DATA(ADEV(ADECOD))
- QUIT
- DO EDIT
- IF '$DATA(ADEV(ADECOD))
- QUIT
- +2 QUIT
- EDIT SET ADENOD=^ADEDIT(ADERDFN,0)
- +1 ;FHL 9/9/98 ;edit not enabled
- IF $PIECE(ADENOD,U,4)="n"
- QUIT
- +2 SET ADEDTYP=$PIECE(ADENOD,U,2)
- +3 IF ADEDTYP=1
- DO E1
- +4 IF ADEDTYP=2
- DO E2
- +5 IF ADEDTYP=3
- DO E3
- +6 IF ADEDTYP=4
- DO E4
- +7 QUIT
- E1 ;EDIT TYPE 1 -- INCOMPATIBLE CODES
- +1 NEW ADEK,ADEPC,ADEVFM,ADEOP,ADEOPC,ADEKK
- +2 ;FIRST GET LIST OF CODES
- +3 SET ADECONF=^ADEDIT(ADERDFN,1)
- +4 ;W "ADECONF=",ADECONF H 1
- IF ADECONF["["
- SET ADECONF=$PIECE(ADECONF,"[",2)
- SET ADECONF=^ADEDIT("GRP",$ORDER(^ADEDIT("GRP","B",ADECONF,0)),1)
- +5 ;SEE IF CURRENT CODE ADECOD IS IN LIST - IF SO, RESOLVE
- +6 ;Opsite specific
- IF $PIECE(^ADEDIT(ADERDFN,0),U,3)]""
- DO E1A
- +7 IF $PIECE(^ADEDIT(ADERDFN,0),U,3)=""
- DO E1B
- +8 QUIT
- E1A FOR ADEKK=1:1:$LENGTH(ADECONF,"|")
- IF $DATA(ADEV($PIECE(ADECONF,"|",ADEKK)))
- IF $PIECE(ADECONF,"|",ADEKK)'=ADECOD
- Begin DoDot:1
- +1 FOR
- IF '$DATA(ADEV(ADECOD))
- QUIT
- SET ADEOP=$PIECE(ADEV(ADECOD),U,2)
- SET ADEPC=ADEOP_","_$PIECE(ADEV($PIECE(ADECONF,"|",ADEKK)),U,2)
- SET ADEOPC=$$DUPE^ADEGRL5C(ADEPC)
- IF 'ADEOPC
- QUIT
- DO RESOLVE^ADEGRL5B
- End DoDot:1
- +2 QUIT
- E1B SET ADEJJ=0
- FOR
- SET ADEJJ=$ORDER(ADEV(ADEJJ))
- IF ADEJJ=""
- QUIT
- IF ADECOD'=ADEJJ
- IF ADECONF[ADEJJ
- DO RESOLVE^ADEGRL5B
- QUIT
- +1 QUIT
- E2 ;EDIT TYPE 2 -- TIME LIMIT ON CODES
- +1 NEW ADEK,ADEPC,ADEVFM,ADEOP,ADEOPC,ADEKK,ADEQTY
- +2 SET ADECONF=^ADEDIT(ADERDFN,1)
- +3 IF ADECONF["["
- SET ADECONF=$PIECE(ADECONF,"[",2)
- SET ADECONF=^ADEDIT("GRP",$ORDER(^ADEDIT("GRP","B",ADECONF,0)),1)
- +4 ;IHS/HMW **2**
- SET X=ADEVDATE
- SET %DT="T"
- DO ^%DT
- SET (ADEVFM,X1)=Y
- KILL %DT,X,Y
- +5 SET X2=$PIECE(^ADEDIT(ADERDFN,2),U)
- +6 ;Delimiter may be | or ;
- SET X2=$TRANSLATE(X2,"|",";")
- +7 SET ADEQTY=$PIECE(X2,";",2)
- SET X2=$PIECE(X2,";")
- +8 IF X2="FY"
- Begin DoDot:1
- +9 ;Set ADELIM to beginning of FY
- +10 SET ADELIM=$$FY^ADEUTL(ADEVDATE)
- End DoDot:1
- +11 IF '$TEST
- Begin DoDot:1
- +12 SET X2=-X2
- +13 DO C^%DTC
- SET ADELIM=X
- KILL X
- End DoDot:1
- +14 ;
- +15 ;$O THRU ADEHXC & SEE IF ANY OF THESE CODES HAVE DATES AFTER LIMIT TIME
- +16 ;Opsite specific
- IF $PIECE(^ADEDIT(ADERDFN,0),U,3)]""
- DO E2A
- +17 IF $PIECE(^ADEDIT(ADERDFN,0),U,3)=""
- DO E2B
- +18 QUIT
- E2A ;
- +1 SET ADEOP=$PIECE(ADEV(ADECOD),U,2)
- +2 ;Q:$D(ADEXFLG)
- FOR ADEK=1:1:$LENGTH(ADEOP,",")
- SET ADEOPC=$PIECE(ADEOP,",",ADEK)
- DO E2A2
- +3 QUIT
- E2A2 FOR ADEKK=1:1:$LENGTH(ADECONF,"|")
- SET ADEPC=$PIECE(ADECONF,"|",ADEKK)
- IF $DATA(ADEHXO(ADEOPC,ADEPC))
- IF $ORDER(ADEHXO(ADEOPC,ADEPC,ADELIM))]""
- IF $ORDER(ADEHXO(ADEOPC,ADEPC,ADELIM))<ADEVFM
- DO E2A3
- QUIT
- +1 QUIT
- E2A3 NEW ADECNT,ADED
- +1 SET ADECNT=0
- SET ADED=ADELIM
- +2 FOR
- SET ADED=$ORDER(ADEHXO(ADEOPC,ADEPC,ADED))
- IF '+ADED
- QUIT
- IF ADED>ADEVFM
- QUIT
- SET ADECNT=ADECNT+1
- +3 IF ADECNT>(ADEQTY-1)
- DO RESOLVE^ADEGRL5B
- +4 QUIT
- E2B FOR ADEK=1:1:$LENGTH(ADECONF,"|")
- SET ADEPC=$PIECE(ADECONF,"|",ADEK)
- IF $DATA(ADEHXC(ADEPC))
- IF $ORDER(ADEHXC(ADEPC,ADELIM))]""
- IF $ORDER(ADEHXC(ADEPC,ADELIM))<ADEVFM
- DO RESOLVE^ADEGRL5B
- QUIT
- +1 QUIT
- +2 ;
- E3 ;Age Screen
- +1 NEW ADEOP,ADEK,ADEPC,ADEOPC,ADETST
- +2 ;FHL 9/9/98 B
- +3 SET ADETST=$PIECE(^ADEDIT(ADERDFN,2),U,4)
- +4 ;I @((AUPNDAYS\365.25)_"'"_$P(^ADEDIT(ADERDFN,2),U,4)) Q
- +5 IF $EXTRACT(ADETST,1,1)=">"!($EXTRACT(ADETST,1,1)="<")
- SET ADETST="'(X"_ADETST_")"
- +6 SET X=AUPNDAYS\365.25
- +7 IF @ADETST
- QUIT
- +8 ;
- +9 ;Opsite specific
- IF $PIECE(^ADEDIT(ADERDFN,0),U,3)]""
- DO E3A
- +10 IF $PIECE(^ADEDIT(ADERDFN,0),U,3)=""
- DO RESOLVE^ADEGRL5B
- +11 QUIT
- E3A SET ADEOP=$PIECE(ADEV(ADECOD),U,2)
- +1 FOR ADEK=1:1:$LENGTH(ADEOP,",")
- SET ADEOPC=$PIECE(ADEOP,",",ADEK)
- DO RESOLVE^ADEGRL5B
- +2 QUIT
- E4 ;Permissible Opsites -use only with codes that require opsites
- +1 ; and use only Resolution 1 (reject)
- +2 NEW ADEPERM,ADEK,ADEOP,ADEOPC
- +3 SET ADEPERM=$PIECE(^ADEDIT(ADERDFN,4),U)
- +4 IF ADEPERM["["
- SET ADEPERM=$PIECE(ADEPERM,"[",2)
- SET ADEPERM=$ORDER(^ADEDIT("GRP","B",ADEPERM,0))
- SET ADEPERM=$PIECE(^ADEDIT("GRP",ADEPERM,1),U)
- +5 FOR ADEK=1:1:$LENGTH(ADEPERM,"|")
- Begin DoDot:1
- +6 SET ADEPC=$PIECE(ADEPERM,"|",ADEK)
- +7 SET ADEPC=$ORDER(^ADEOPS("B",ADEPC,0))
- +8 IF ADEPC
- SET ADEPERM(ADEPC)=""
- End DoDot:1
- +9 SET ADEOP=$PIECE(ADEV(ADECOD),U,2)
- +10 ;IHS;SD;TPF H31091 PATCH 23
- IF 'ADEOP
- QUIT
- +11 FOR ADEK=1:1:$LENGTH(ADEOP,",")
- SET ADEOPC=$PIECE(ADEOP,",",ADEK)
- Begin DoDot:1
- +12 IF '$DATA(ADEPERM(ADEOPC))
- DO RESOLVE^ADEGRL5B
- End DoDot:1
- +13 QUIT
- +14 ;*NE
- KILL ADEPERM
