AQALDG53.m

AQALDG53 ; IHS/ORDC/LJF - LINK EDITED ADT EVENTS ;

 ;;1;QI LINKAGES-RPMS;;AUG 15, 1994

 ;

 ;This routine handles edits to ADT events and decides what, if any

 ;action to perform on the QI Occurrence file.

 ;

INIT ; >> find ind for event type

 K AQALPAR

 I DGPMT=1 F I=2,12,22 D PARAM

 I DGPMT=2 F I=32,72 D PARAM

 I DGPMT=3 F I=42,52,62 D PARAM

 ;

 ; >> find all auto occ from ADT for pt and visit and event type

 S AQALN=0

 F  S AQALN=$O(^AQAOC("AE",DFN,AQALVST,AQALN)) Q:AQALN=""  D

 .Q:'$D(^AQAOC(AQALN,0))  Q:$P(^(0),U,11)=""  ;not automatic entry

 .I DGPMT=2 Q:+DGPMP'=$P(^AQAOC(AQALN,0),U,4)  ;not same transf dt

 .S X=$P($G(^AQAO(2,+$P(^AQAOC(AQALN,0),U,8),0)),U) ;ind number

 .Q:'$D(AQALPAR(X))  ;occ not for same admit event

 .S AQALAUT(X)=AQALN ;set array of occ for DGPMT that exist

 ;

 ; >> calculate event and create or modify occ

 I DGPMA]"" S X=DGPMT_"^AQALDG5" D @X

 ;

 ; >> delete any occurrences not edited (aqalaut(x) deleted if edited)

 S AQALX=0

 F  S AQALX=$O(AQALAUT(AQALX)) Q:AQALX=""  D

 .S AQALN=AQALAUT(AQALX) D DEL^AQALNK1(AQALN) ;delete occ

 Q

 ;

 ;

PARAM ; >> SUBRTN to find indicator numbers for adt event type

 S X=$P($G(^AQAGP(DUZ(2),"ADT")),U,I)

 I X]"" S AQALPAR(X)=""

 Q

AQALDG53  ; IHS/ORDC/LJF - LINK EDITED ADT EVENTS ;

 +1       ;;1;QI LINKAGES-RPMS;;AUG 15, 1994

 +2       ;

 +3       ;This routine handles edits to ADT events and decides what, if any

 +4       ;action to perform on the QI Occurrence file.

 +5       ;

INIT      ; >> find ind for event type

 +1        KILL AQALPAR

 +2        IF DGPMT=1

               FOR I=2,12,22

                   DO PARAM

 +3        IF DGPMT=2

               FOR I=32,72

                   DO PARAM

 +4        IF DGPMT=3

               FOR I=42,52,62

                   DO PARAM

 +5       ;

 +6       ; >> find all auto occ from ADT for pt and visit and event type

 +7        SET AQALN=0

 +8        FOR 

               SET AQALN=$ORDER(^AQAOC("AE",DFN,AQALVST,AQALN))

               IF AQALN=""

                   QUIT 

               Begin DoDot:1

 +9       ;not automatic entry

                   IF '$DATA(^AQAOC(AQALN,0))

                       QUIT 

                   IF $PIECE(^(0),U,11)=""

                       QUIT 

 +10      ;not same transf dt

                   IF DGPMT=2

                       IF +DGPMP'=$PIECE(^AQAOC(AQALN,0),U,4)

                           QUIT 

 +11      ;ind number

                   SET X=$PIECE($GET(^AQAO(2,+$PIECE(^AQAOC(AQALN,0),U,8),0)),U)

 +12      ;occ not for same admit event

                   IF '$DATA(AQALPAR(X))

                       QUIT 

 +13      ;set array of occ for DGPMT that exist

                   SET AQALAUT(X)=AQALN

               End DoDot:1

 +14      ;

 +15      ; >> calculate event and create or modify occ

 +16       IF DGPMA]""

               SET X=DGPMT_"^AQALDG5"

               DO @X

 +17      ;

 +18      ; >> delete any occurrences not edited (aqalaut(x) deleted if edited)

 +19       SET AQALX=0

 +20       FOR 

               SET AQALX=$ORDER(AQALAUT(AQALX))

               IF AQALX=""

                   QUIT 

               Begin DoDot:1

 +21      ;delete occ

                   SET AQALN=AQALAUT(AQALX)

                   DO DEL^AQALNK1(AQALN)

               End DoDot:1

 +22       QUIT 

 +23      ;

 +24      ;

PARAM     ; >> SUBRTN to find indicator numbers for adt event type

 +1        SET X=$PIECE($GET(^AQAGP(DUZ(2),"ADT")),U,I)

 +2        IF X]""

               SET AQALPAR(X)=""

 +3        QUIT