Routine: ORY7

ORY7 ;SLB/MKB-postinit for OR*3.0*7 ;3/20/98  14:45

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7**;Dec 17, 1997

POST ; -- Set ^ORD(100.03,"D"), value for Lab parameter

 N DIK,ORX

 I '$D(^ORD(100.03,"D")) S DIK="^ORD(100.03,",DIK(1)=".01^D" D ENALL^DIK

 S ORX=$P($G(^ORD(100.99,1,0)),U,18)

 D:$L(ORX) EN^XPAR("SYS","ORPF SHOW LAB #",1,ORX)

PRE ; -- preinit cleanup of Order Reason file #100.03

 N DA,DIK,ORSYN,ORNM,ORI,ORACTV,ORINACT,ORX

 S DA=.001,DA(1)=100.03,DIK="^DD(100.03," D ^DIK ;remove NUMBER field

 F ORSYN="DUP","ER" D  ;cleanup duplicates

 . K ORACTV,ORINACT S ORI=0

 . F  S ORI=$O(^ORD(100.03,"S",ORSYN,ORI)) Q:ORI'>0  D

 .. S ORX=$G(^ORD(100.03,+ORI,0))

 .. I $P(ORX,U,4) S ORINACT=+$G(ORINACT)+1,ORINACT(+ORI)=ORX

 .. E  S ORACTV=+$G(ORACTV)+1,ORACTV(+ORI)=ORX

 . S ORNM=$S(ORSYN="DUP":"Duplicate Order",1:"Entered in error")

 . I $G(ORINACT) S ORI=0 F  S ORI=$O(ORINACT(ORI)) Q:ORI'>0  S ORX=ORINACT(ORI) D INACT

 . S ORI=$O(ORACTV(0)) Q:ORI'>0  S ORX=ORACTV(ORI)

 . I ORSYN="DUP",ORNM'=$P(ORX,U) D SETNM(ORI,ORNM)

 . I ORSYN="ER",'$P(ORX,U,7) S $P(^ORD(100.03,ORI,0),U,7)=+$O(^ORD(100.02,"C","M",0)) ;set nature="maintenance"

 . I $G(ORACTV)>1 F  S ORI=$O(ORACTV(ORI)) Q:ORI'>0  S ORX=ORACTV(ORI) D INACT ;inactivate extra entries

INACT ; -- inactivate reason

 N DA,DR,DIE,X,Y

 S DA=ORI,DIE="^ORD(100.03,",DR=".03///@;.04////1;.06///@"

 S:ORNM=$P(ORX,U) DR=".01///Z"_ORNM_";"_DR D ^DIE

SETNM(DA,X) ; -- set .01 Name

 N DR,DIE,Y Q:'DA

 S DIE="^ORD(100.03,",DR=".01///"_X D ^DIE

ORY7      ;SLB/MKB-postinit for OR*3.0*7 ;3/20/98  14:45

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7**;Dec 17, 1997

 +2       ;

POST      ; -- Set ^ORD(100.03,"D"), value for Lab parameter

 +1       ;

 +2        NEW DIK,ORX

 +3        IF '$DATA(^ORD(100.03,"D"))

               SET DIK="^ORD(100.03,"

               SET DIK(1)=".01^D"

               DO ENALL^DIK

 +4        SET ORX=$PIECE($GET(^ORD(100.99,1,0)),U,18)

 +5        IF $LENGTH(ORX)

               DO EN^XPAR("SYS","ORPF SHOW LAB #",1,ORX)

 +6        QUIT

 +7       ;

PRE       ; -- preinit cleanup of Order Reason file #100.03

 +1        NEW DA,DIK,ORSYN,ORNM,ORI,ORACTV,ORINACT,ORX

 +2       ;remove NUMBER field

           SET DA=.001

           SET DA(1)=100.03

           SET DIK="^DD(100.03,"

           DO ^DIK

 +3       ;cleanup duplicates

           FOR ORSYN="DUP","ER"

               Begin DoDot:1

 +4                KILL ORACTV,ORINACT

                   SET ORI=0

 +5                FOR

                       SET ORI=$ORDER(^ORD(100.03,"S",ORSYN,ORI))

                       IF ORI'>0

                           QUIT

                       Begin DoDot:2

 +6                        SET ORX=$GET(^ORD(100.03,+ORI,0))

 +7                        IF $PIECE(ORX,U,4)

                               SET ORINACT=+$GET(ORINACT)+1

                               SET ORINACT(+ORI)=ORX

 +8                       IF '$TEST

                               SET ORACTV=+$GET(ORACTV)+1

                               SET ORACTV(+ORI)=ORX

                       End DoDot:2

 +9                SET ORNM=$SELECT(ORSYN="DUP":"Duplicate Order",1:"Entered in error")

 +10               IF $GET(ORINACT)

                       SET ORI=0

FOR

                           SET ORI=$ORDER(ORINACT(ORI))

                           IF ORI'>0

                               QUIT

                           SET ORX=ORINACT(ORI)

                           DO INACT

 +11               SET ORI=$ORDER(ORACTV(0))

                   IF ORI'>0

                       QUIT

                   SET ORX=ORACTV(ORI)

 +12               IF ORSYN="DUP"

                       IF ORNM'=$PIECE(ORX,U)

                           DO SETNM(ORI,ORNM)

 +13      ;set nature="maintenance"

                   IF ORSYN="ER"

                       IF '$PIECE(ORX,U,7)

                           SET $PIECE(^ORD(100.03,ORI,0),U,7)=+$ORDER(^ORD(100.02,"C","M",0))

 +14      ;inactivate extra entries

                   IF $GET(ORACTV)>1

FOR

                           SET ORI=$ORDER(ORACTV(ORI))

                           IF ORI'>0

                               QUIT

                           SET ORX=ORACTV(ORI)

                           DO INACT

               End DoDot:1

 +15       QUIT

 +16      ;

INACT     ; -- inactivate reason

 +1        NEW DA,DR,DIE,X,Y

 +2        SET DA=ORI

           SET DIE="^ORD(100.03,"

           SET DR=".03///@;.04////1;.06///@"

 +3        IF ORNM=$PIECE(ORX,U)

               SET DR=".01///Z"_ORNM_";"_DR

           DO ^DIE

 +4        QUIT

 +5       ;

SETNM(DA,X) ; -- set .01 Name

 +1        NEW DR,DIE,Y

           IF 'DA

               QUIT

 +2        SET DIE="^ORD(100.03,"

           SET DR=".01///"_X

           DO ^DIE

 +3        QUIT

ORY7.m