APCPAA.m

APCPAA ; IHS/TUCSON/LAB - create APC transactions AUG 14, 1992 ; [ 09/16/02 12:13 PM ]

 ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;**1,6**;APR 03, 1998

 ;IHS/CMI/LAB - no longer send APC records

 ;

START ;

 D SETVARS

 D ^APCPAPRO

 I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q

 D ^APCPAPOV

 I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q

 D ^APCPAOTH

 I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q

 D LAB

 D PROC

 I $D(APCPE("ERROR")) D COUNT^APCPDR2,EOJ Q

 D SETTX

 D EOJ

 Q

 ;

EOJ ;

 K APCPADX1,APCPADX2,I,APCPT,D

 Q

SETVARS ; set standard variables for record

 K APCPT

 S APCPT("VD")=$E(APCPV("V DATE"),4,5)_$E(APCPV("V DATE"),6,7)_$E(APCPV("V DATE"),2,3)

 S X=APCPV("V DATE") D H^%DTC S APCPT("DOW")=%Y+1 K X,%T,%Y

 S APCPT("HR")=$E($P(+$P(APCPV("V REC"),U),".",2),1,2) I APCPT("HR")="" S APCPT("HR")=12

 S APCPT("TOD")=$S(APCPT("HR")>7&(APCPT("HR")<12):1,APCPT("HR")>11&(APCPT("HR")<17):2,APCPT("HR")>16&(APCPT("HR")<22):3,1:4)

 S:APCPV("CLINIC CODE")="" APCPV("CLINIC CODE")=25

DISP ;set disposition to 2 - if admission on same day, set to 3

 NEW D,I

 S APCPT("DISP")=2,D=9999999-APCPV("V DATE"),I=$O(^AUPNVSIT("AAH",APCPV("PATIENT DFN"),D)) I I]"",(I\1)=D S APCPT("DISP")=3

 Q

LAB ;

 S APCPT("LAB")=$S($D(^AUPNVLAB("AD",APCP("V DFN"))):"        8  ",1:"0          ")

 Q

PROC ;

 S (APCPT("OP"),APCPT("SP"))=""

 I $D(^AUPNVPRC("AD",APCP("V DFN"))) S APCPT("SP")=1,APCPT("X")=$O(^AUPNVPRC("AD",APCP("V DFN"),"")),APCPT("OPP")=$P(^AUPNVPRC(APCPT("X"),0),U) D OPCODE

 Q

OPCODE ; 

 S APCPT("OP")=$P(^ICD0(APCPT("OPP"),0),U)

 I $P(^ICD0(APCPT("OPP"),0),U,9)]"" S APCPE("ERROR")="E041" Q

 I $P(^ICD0(APCPT("OPP"),0),U,10)]"",AUPNSEX'=$P(^ICD0(APCPT("OPP"),0),U,10) S APCPE("ERROR")="E043" Q

 I APCPT("OP")=.9999 S APCPE("ERROR")="E032" Q

 I $L($P(APCPT("OP"),".",2))>2 S APCPE("ERROR")="E007" Q

 S APCPT("OP")=$P(APCPT("OP"),".")_$P(APCPT("OP"),".",2),APCPT("L")=$L(APCPT("OP"))+1 F I=APCPT("L"):1:4 S APCPT("OP")=APCPT("OP")_" "

 ;

 Q

SETTX ;

 Q  ;IHS/CMI/LAB - patch 1 NO LONGER SEND APC RECORDS per hdqtrs west

 S APCP("APC")=APCP("APC")+1,APCP("COUNT")=APCP("COUNT")+1

 S APCPV("TX GENERATED")=1,^XTMP("APCP"_$S(APCPO("RUN")="NEW":"DR",APCPO("RUN")="REDO":"REDO",1:"DR"),"MAIN TX",APCP("V DFN"))=APCP("MAIN TX DATE")

 NEW Y S Y=0 F  S Y=$O(^APCPREC(1,11,"B",Y)) Q:Y'=+Y  D

 .S X=""

 .S Z=$O(^APCPREC(1,11,"B",Y,0))

 .Q:'$D(^APCPREC(1,11,Z,1))

 .X ^APCPREC(1,11,Z,1)

 .S $P(APCPV("TX"),U,Y)=X

 S ^BAPCDATA(APCP("COUNT"))="AP1"_U_APCPV("TX")

 Q

APCPAA    ; IHS/TUCSON/LAB - create APC transactions AUG 14, 1992 ; [ 09/16/02 12:13 PM ]

 +1       ;;2.0;IHS PCC DATA EXTRACTION SYSTEM;**1,6**;APR 03, 1998

 +2       ;IHS/CMI/LAB - no longer send APC records

 +3       ;

START     ;

 +1        DO SETVARS

 +2        DO ^APCPAPRO

 +3        IF $DATA(APCPE("ERROR"))

               DO COUNT^APCPDR2

               DO EOJ

               QUIT 

 +4        DO ^APCPAPOV

 +5        IF $DATA(APCPE("ERROR"))

               DO COUNT^APCPDR2

               DO EOJ

               QUIT 

 +6        DO ^APCPAOTH

 +7        IF $DATA(APCPE("ERROR"))

               DO COUNT^APCPDR2

               DO EOJ

               QUIT 

 +8        DO LAB

 +9        DO PROC

 +10       IF $DATA(APCPE("ERROR"))

               DO COUNT^APCPDR2

               DO EOJ

               QUIT 

 +11       DO SETTX

 +12       DO EOJ

 +13       QUIT 

 +14      ;

EOJ       ;

 +1        KILL APCPADX1,APCPADX2,I,APCPT,D

 +2        QUIT 

SETVARS   ; set standard variables for record

 +1        KILL APCPT

 +2        SET APCPT("VD")=$EXTRACT(APCPV("V DATE"),4,5)_$EXTRACT(APCPV("V DATE"),6,7)_$EXTRACT(APCPV("V DATE"),2,3)

 +3        SET X=APCPV("V DATE")

           DO H^%DTC

           SET APCPT("DOW")=%Y+1

           KILL X,%T,%Y

 +4        SET APCPT("HR")=$EXTRACT($PIECE(+$PIECE(APCPV("V REC"),U),".",2),1,2)

           IF APCPT("HR")=""

               SET APCPT("HR")=12

 +5        SET APCPT("TOD")=$SELECT(APCPT("HR")>7&(APCPT("HR")<12):1,APCPT("HR")>11&(APCPT("HR")<17):2,APCPT("HR")>16&(APCPT("HR")<22):3,1:4)

 +6        IF APCPV("CLINIC CODE")=""

               SET APCPV("CLINIC CODE")=25

DISP      ;set disposition to 2 - if admission on same day, set to 3

 +1        NEW D,I

 +2        SET APCPT("DISP")=2

           SET D=9999999-APCPV("V DATE")

           SET I=$ORDER(^AUPNVSIT("AAH",APCPV("PATIENT DFN"),D))

           IF I]""

               IF (I\1)=D

                   SET APCPT("DISP")=3

 +3        QUIT 

LAB       ;

 +1        SET APCPT("LAB")=$SELECT($DATA(^AUPNVLAB("AD",APCP("V DFN"))):"        8  ",1:"0          ")

 +2        QUIT 

PROC      ;

 +1        SET (APCPT("OP"),APCPT("SP"))=""

 +2        IF $DATA(^AUPNVPRC("AD",APCP("V DFN")))

               SET APCPT("SP")=1

               SET APCPT("X")=$ORDER(^AUPNVPRC("AD",APCP("V DFN"),""))

               SET APCPT("OPP")=$PIECE(^AUPNVPRC(APCPT("X"),0),U)

               DO OPCODE

 +3        QUIT 

OPCODE    ; 

 +1        SET APCPT("OP")=$PIECE(^ICD0(APCPT("OPP"),0),U)

 +2        IF $PIECE(^ICD0(APCPT("OPP"),0),U,9)]""

               SET APCPE("ERROR")="E041"

               QUIT 

 +3        IF $PIECE(^ICD0(APCPT("OPP"),0),U,10)]""

               IF AUPNSEX'=$PIECE(^ICD0(APCPT("OPP"),0),U,10)

                   SET APCPE("ERROR")="E043"

                   QUIT 

 +4        IF APCPT("OP")=.9999

               SET APCPE("ERROR")="E032"

               QUIT 

 +5        IF $LENGTH($PIECE(APCPT("OP"),".",2))>2

               SET APCPE("ERROR")="E007"

               QUIT 

 +6        SET APCPT("OP")=$PIECE(APCPT("OP"),".")_$PIECE(APCPT("OP"),".",2)

           SET APCPT("L")=$LENGTH(APCPT("OP"))+1

           FOR I=APCPT("L"):1:4

               SET APCPT("OP")=APCPT("OP")_" "

 +7       ;

 +8        QUIT 

SETTX     ;

 +1       ;IHS/CMI/LAB - patch 1 NO LONGER SEND APC RECORDS per hdqtrs west

           QUIT 

 +2        SET APCP("APC")=APCP("APC")+1

           SET APCP("COUNT")=APCP("COUNT")+1

 +3        SET APCPV("TX GENERATED")=1

           SET ^XTMP("APCP"_$SELECT(APCPO("RUN")="NEW":"DR",APCPO("RUN")="REDO":"REDO",1:"DR"),"MAIN TX",APCP("V DFN"))=APCP("MAIN TX DATE")

 +4        NEW Y

           SET Y=0

           FOR 

               SET Y=$ORDER(^APCPREC(1,11,"B",Y))

               IF Y'=+Y

                   QUIT 

               Begin DoDot:1

 +5                SET X=""

 +6                SET Z=$ORDER(^APCPREC(1,11,"B",Y,0))

 +7                IF '$DATA(^APCPREC(1,11,Z,1))

                       QUIT 

 +8                XECUTE ^APCPREC(1,11,Z,1)

 +9                SET $PIECE(APCPV("TX"),U,Y)=X

               End DoDot:1

 +10       SET ^BAPCDATA(APCP("COUNT"))="AP1"_U_APCPV("TX")

 +11       QUIT